Changeset 5246 for LMDZ6/trunk/libf/phylmd/inlandsis
- Timestamp:
- Oct 21, 2024, 2:58:45 PM (4 months ago)
- Location:
- LMDZ6/trunk/libf/phylmd/inlandsis
- Files:
-
- 12 moved
-
inlandsis.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/inlandsis.F) (1 diff)
-
sisvat_bsn.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_bsn.F) (1 diff)
-
sisvat_gsn.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_gsn.F) (1 diff)
-
sisvat_qsn.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_qsn.F) (1 diff)
-
sisvat_qso.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_qso.F) (1 diff)
-
sisvat_sno_albedo.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_sno_albedo.F) (1 diff)
-
sisvat_ts2.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_ts2.F) (1 diff)
-
sisvat_tso.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_tso.F) (1 diff)
-
sisvat_weq.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_weq.F) (1 diff)
-
sisvat_zag.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_zag.F) (1 diff)
-
sisvat_zcr.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_zcr.F) (1 diff)
-
sisvat_zsn.f90 (moved) (moved from LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_zsn.F) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/trunk/libf/phylmd/inlandsis/inlandsis.f90
r5245 r5246 1 subroutine INLANDSIS(SnoMod,BloMod,jjtime,debut) 2 3 USE dimphy 4 5 !--------------------------------------------------------------------------+ 6 ! INLANDSIS module | 7 ! Simplified SISVAT module, containing ice and snow processes for | 8 ! ice-covered surfaces | 9 ! version MARv3, november 2020 | 10 ! SubRoutine INLANDSIS contains the fortran 77 code of the | 11 ! Soil/Ice Snow Vegetation Atmosphere Transfer Scheme | 12 ! | 13 !--------------------------------------------------------------------------+ 14 ! PARAMETERS: klonv: Total Number of columns = | 15 ! ^^^^^^^^^^ = Total Number of continental grid boxes | 16 ! X Number of Mosaic Cell per grid box | 17 ! | 18 ! INPUT: daHost : Date Host Model | 19 ! ^^^^^ | 20 ! | 21 ! INPUT: LSmask : 1: Land MASK | 22 ! ^^^^^ 0: Sea MASK | 23 ! isotSV = 0,...,12: Soil Type | 24 ! 0: Water, Liquid (Sea, Lake) | 25 ! 12: Water, Solid (Ice) | 26 ! | 27 ! INPUT: coszSV : Cosine of the Sun Zenithal Distance [-] | 28 ! ^^^^^ sol_SV : Surface Downward Solar Radiation [W/m2] | 29 ! IRd_SV : Surface Downward Longwave Radiation [W/m2] | 30 ! drr_SV : Rain Intensity [kg/m2/s] | 31 ! dsn_SV : Snow Intensity [mm w.e./s] | 32 ! dsnbSV : Snow Intensity, Drift Fraction [-] | 33 ! dbs_SV : Drift Amount [mm w.e.] | 34 ! za__SV : Surface Boundary Layer (SBL) Height [m] | 35 ! VV__SV :(SBL Top) Wind Velocity [m/s] | 36 ! TaT_SV : SBL Top Temperature [K] | 37 ! rhT_SV : SBL Top Air Density [kg/m3] | 38 ! QaT_SV : SBL Top Specific Humidity [kg/kg] | 39 ! qsnoSV : SBL Mean Snow Content [kg/kg] | 40 ! alb0SV : Soil Basic Albedo [-] | 41 ! slopSV : Surface Slope [-] | 42 ! dt__SV : Time Step [s] | 43 ! | 44 ! INPUT / isnoSV = total Nb of Ice/Snow Layers | 45 ! OUTPUT: ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer | 46 ! ^^^^^^ iiceSV = total Nb of Ice Layers | 47 ! istoSV = 0,...,5 : Snow History (see istdSV data) | 48 ! | 49 ! INPUT / alb_SV : Surface Albedo [-] | 50 ! OUTPUT: emi_SV : Surface Emissivity [-] | 51 ! ^^^^^^ IRs_SV : Soil IR Flux (negative) [W/m2] | 52 ! LMO_SV : Monin-Obukhov Scale [m] | 53 ! us__SV : Friction Velocity [m/s] | 54 ! uts_SV : Temperature Turbulent Scale [m/s] | 55 ! uqs_SV : Specific Humidity Velocity [m/s] | 56 ! uss_SV : Blowing Snow Turbulent Scale [m/s] | 57 ! usthSV : Blowing Snow Erosion Threshold [m/s] | 58 ! Z0m_SV : Momentum Roughness Length [m] | 59 ! Z0mmSV : Momentum Roughness Length (time mean) [m] | 60 ! Z0mnSV : Momentum Roughness Length (instantaneous)[m] | 61 ! Z0SaSV : Sastrugi Roughness Length [m] | 62 ! Z0e_SV : Erosion Snow Roughness Length [m] | 63 ! Z0emSV : Erosion Snow Roughness Length (time mean) [m] | 64 ! Z0enSV : Erosion Snow Roughness Length (instantaneous)[m] | 65 ! Z0roSV : Subgrid Topo Roughness Length [m] | 66 ! Z0h_SV : Heat Roughness Length [m] | 67 ! TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 68 ! & Snow Temperatures (layers 1,2,...,nsno) [K] | 69 ! ro__SV : Soil/Snow Volumic Mass [kg/m3] | 70 ! eta_SV : Soil/Snow Water Content [m3/m3] | 71 ! G1snSV : snow dendricity/sphericity | 72 ! G2snSV : snow sphericity/grain size | 73 ! dzsnSV : Snow Layer Thickness [m] | 74 ! agsnSV : Snow Age [day] | 75 ! BufsSV : Snow Buffer Layer [kg/m2] .OR. [mm] | 76 ! BrosSV : Snow Buffer Layer Density [kg/m3] | 77 ! BG1sSV : Snow Buffer Layer Dendricity / Sphericity [-] | 78 ! BG2sSV : Snow Buffer Layer Sphericity / Size [-] [0.1 mm] | 79 ! rusnSV : Surficial Water [kg/m2] .OR. [mm] | 80 ! | 81 ! OUTPUT: no__SV : OUTPUT file Unit Number [-] | 82 ! ^^^^^^ i___SV : OUTPUT point i Coordinate [-] | 83 ! j___SV : OUTPUT point j Coordinate [-] | 84 ! n___SV : OUTPUT point n Coordinate [-] | 85 ! lwriSV : OUTPUT point vec Index [-] | 86 ! | 87 ! OUTPUT: IRu_SV : Upward IR Flux (+, upw., effective) [K] | 88 ! ^^^^^^ hSalSV : Saltating Layer Height [m] | 89 ! qSalSV : Saltating Snow Concentration [kg/kg] | 90 ! RnofSV : RunOFF Intensity [kg/m2/s] | 91 ! | 92 ! Internal Variables: | 93 ! ^^^^^^^^^^^^^^^^^^ | 94 ! NLaysv = New Snow Layer Switch [-] | 95 ! albisv : Snow/Ice/Water/Soil Integrated Albedo [-] | 96 ! SoSosv : Absorbed Solar Radiation by Surfac.(Normaliz)[-] | 97 ! TBr_sv : Brightness Temperature [K] | 98 ! IRupsv : Upward IR Flux (-, upw.) [W/m2] | 99 ! ram_sv : Aerodynamic Resistance for Momentum [s/m] | 100 ! rah_sv : Aerodynamic Resistance for Heat [s/m] | 101 ! Evp_sv : Evaporation [kg/m2] | 102 ! EvT_sv : Evapotranspiration [kg/m2] | 103 ! HSs_sv : Surface Sensible Heat Flux + => absorb.[W/m2] | 104 ! HLs_sv : Surface Latent Heat Flux + => absorb.[W/m2] | 105 ! Lx_H2O : Latent Heat of Vaporization/Sublimation [J/kg] | 106 ! Tsrfsv : Surface Temperature [K] | 107 ! sEX_sv : Verticaly Integrated Extinction Coefficient [-] | 108 ! LSdzsv : Vertical Discretization Factor [-] | 109 ! = 1. Soil | 110 ! = 1000. Ocean | 111 ! z_snsv : Snow Pack Thickness [m] | 112 ! zzsnsv : Snow Pack Thickness [m] | 113 ! albssv : Soil Albedo [-] | 114 ! Eso_sv : Soil+Snow Emissivity [-] | 115 ! Khydsv : Soil Hydraulic Conductivity [m/s] | 116 ! | 117 ! ETSo_0 : Snow/Soil Energy Power, before Forcing [W/m2] | 118 ! ETSo_1 : Snow/Soil Energy Power, after Forcing [W/m2] | 119 ! ETSo_d : Snow/Soil Energy Power Forcing [W/m2] | 120 ! EqSn_0 : Snow Energy, before Phase Change [J/m2] | 121 ! EqSn_1 : Snow Energy, after Phase Change [J/m2] | 122 ! EqSn_d : Snow Energy, net Forcing [J/m2] | 123 ! Enrsvd : SVAT Energy Power Forcing [W/m2] | 124 ! Enrbal : SVAT Energy Balance [W/m2] | 125 ! Wats_0 : Soil Water, before Forcing [mm] | 126 ! Wats_1 : Soil Water, after Forcing [mm] | 127 ! Wats_d : Soil Water Forcing [mm] | 128 ! SIWm_0 : Snow initial Mass [mm w.e.] | 129 ! SIWm_1 : Snow final Mass [mm w.e.] | 130 ! SIWa_i : Snow Atmos. initial Forcing [mm w.e.] | 131 ! SIWa_f : Snow Atmos. final Forcing(noConsumed)[mm w.e.] | 132 ! SIWe_i : SnowErosion initial Forcing [mm w.e.] | 133 ! SIWe_f : SnowErosion final Forcing(noConsumed)[mm w.e.] | 134 ! SIsubl : Snow sublimed/deposed Mass [mm w.e.] | 135 ! SImelt : Snow Melted Mass [mm w.e.] | 136 ! SIrnof : Surficial Water + Run OFF Change [mm w.e.] | 137 ! SIvAcr : Sea-Ice vertical Acretion [mm w.e.] | 138 ! Watsvd : SVAT Water Forcing [mm] | 139 ! Watbal : SVAT Water Balance [W/m2] | 140 ! | 141 ! vk2 : Square of Von Karman Constant [-] | 142 ! sqrCm0 : Factor of Neutral Drag Coeffic.Momentum [s/m] | 143 ! sqrCh0 : Factor of Neutral Drag Coeffic.Heat [s/m] | 144 ! EmiSol : Soil Emissivity [-] | 145 ! EmiSno : Snow Emissivity [-] | 146 ! EmiWat : Water Emissivity [-] | 147 ! Z0mLnd : Land Roughness Length [m] | 148 ! sqrrZ0 : u*t/u* | 149 ! f_eff : Marticorena & B. 1995 JGR (20) | 150 ! A_Fact : Fundamental * Roughness | 151 ! Z0mBSn : BSnow Roughness Length [m] | 152 ! Z0mBS0 : Mimimum BSnow Roughness Length (blown* ) [m] | 153 ! Z0m_Sn : Snow Roughness Length (surface) [m] | 154 ! Z0m_S0 : Mimimum Snow Roughness Length [m] | 155 ! Z0m_S1 : Maximum Snow Roughness Length [m] | 156 ! Z0_GIM : Minimum GIMEX Roughness Length [m] | 157 ! Z0_ICE : Sea Ice ISW Roughness Length [m] | 158 ! | 159 ! | 160 !--------------------------------------------------------------------------+ 161 162 163 164 ! Global Variables 165 ! ================ 166 167 168 USE VARphy 169 USE VAR_SV 170 USE VARdSV 171 USE VAR0SV 172 USE VARxSV 173 USE VARySV 174 USE VARtSV 175 USE surface_data, ONLY: is_ok_z0h_rn, 176 . is_ok_density_kotlyakov, 177 . prescribed_z0m_snow, 178 . iflag_z0m_snow, 179 . iflag_tsurf_inlandsis, 180 . iflag_temp_inlandsis, 181 . discret_xf, buf_sph_pol,buf_siz_pol 182 183 IMPLICIT NONE 184 185 logical SnoMod 186 logical BloMod 187 logical debut 188 integer jjtime 189 190 191 ! Internal Variables 192 ! ================== 193 194 ! Non Local 195 ! --------- 196 197 real TBr_sv(klonv) ! Brightness Temperature 198 real IRdwsv(klonv) ! DOWNward IR Flux 199 real IRupsv(klonv) ! UPward IR Flux 200 real d_Bufs,Bufs_N ! Buffer Snow Layer Increment 201 real Buf_ro,Bros_N ! Buffer Snow Layer Density 202 real BufPro ! Buffer Snow Layer Density 203 real Buf_G1,BG1__N ! Buffer Snow Layer Dendr/Sphe[-] 204 real Buf_G2,BG2__N ! Buffer Snow Layer Spher/Size[-] 205 real Bdzssv(klonv) ! Buffer Snow Layer Thickness 206 real z_snsv(klonv) ! Snow-Ice, current Thickness 207 208 209 210 ! Local 211 ! ----- 212 213 integer iwr 214 integer ikl ,isn ,isl ,ist ! 215 integer ist__s,ist__w ! Soil/Water Body Identifier 216 integer growth ! Seasonal Mask 217 integer LISmsk ! Land+Ice / Open Sea Mask 218 integer LSnMsk ! Snow-Ice / No Snow-Ice Mask 219 integer IceMsk,IcIndx(klonv) ! Ice / No Ice Mask 220 integer SnoMsk ! Snow / No Snow Mask 221 real roSMin,roSMax,roSn_1,roSn_2,roSn_3 ! Fallen Snow Density (PAHAUT) 222 real Dendr1,Dendr2,Dendr3 ! Fallen Snow Dendric.(GIRAUD) 223 real Spher1,Spher2,Spher3,Spher4 ! Fallen Snow Spheric.(GIRAUD) 224 real Polair ! Polar Snow Switch 225 real PorSno,Salt_f,PorRef ! 226 c #sw real PorVol,rWater ! 227 c #sw real rusNEW,rdzNEW,etaNEW ! 228 real ro_new ! 229 real TaPole ! Maximum Polar Temperature 230 real T__Min ! Minimum realistic Temperature 231 real EmiSol ! Emissivity of Soil 232 real EmiSno ! Emissivity of Snow 233 real EmiWat ! Emissivity of a Water Area 234 real vk2 ! Square of Von Karman Constant 235 real u2star !(u*)**2 236 real Z0mLnd ! Land Roughness Length 237 c #ZN real sqrrZ0 ! u*t/u* 238 real f_eff ! Marticorena & B. 1995 JGR (20) 239 real A_Fact ! Fundamental * Roughness 240 real Z0m_nu ! Smooth R Snow Roughness Length 241 real Z0mBSn ! BSnow Roughness Length 242 real Z0mBS0 ! Mimimum BSnow Roughness Length 243 real Z0m_S0 ! Mimimum Snow Roughness Length 244 real Z0m_S1 ! Maximum Snow Roughness Length 245 c #SZ real Z0Sa_N ! Regime Snow Roughness Length 246 c #SZ real Z0SaSi ! 1.IF Rgm Snow Roughness Length 247 c #GL real Z0_GIM ! Mimimum GIMEX Roughness Length 248 real Z0_ICE ! Ice ISW Roughness Length 249 real Z0m_Sn,Z0m_90 ! Snow Surface Roughness Length 250 real SnoWat ! Snow Layer Switch 251 real rstar,alors ! 252 real rstar0,rstar1,rstar2 ! 253 real SameOK ! 1. => Same Type of Grains 254 real G1same ! Averaged G1, same Grains 255 real G2same ! Averaged G2, same Grains 256 real typ__1 ! 1. => Lay1 Type: Dendritic 257 real zroNEW ! dz X ro, if fresh Snow 258 real G1_NEW ! G1, if fresh Snow 259 real G2_NEW ! G2, if fresh Snow 260 real zroOLD ! dz X ro, if old Snow 261 real G1_OLD ! G1, if old Snow 262 real G2_OLD ! G2, if old Snow 263 real SizNEW ! Size, if fresh Snow 264 real SphNEW ! Spheric.,if fresh Snow 265 real SizOLD ! Size, if old Snow 266 real SphOLD ! Spheric.,if old Snow 267 real Siz_av ! Averaged Grain Size 268 real Sph_av ! Averaged Grain Spher. 269 real Den_av ! Averaged Grain Dendr. 270 real G1diff ! Averaged G1, diff. Grains 271 real G2diff ! Averaged G2, diff. Grains 272 real G1 ! Averaged G1 273 real G2 ! Averaged G2 274 real param ! Polynomial fit z0=f(T) 275 real Z0_obs ! Fit Z0_obs=f(T) (m) 276 real tamin ! min T of linear fit (K) 277 real tamax ! max T of linear fit (K) 278 real coefa,coefb,coefc,coefd ! Coefs for z0=f(T) 279 real ta1,ta2,ta3 ! Air temperature thresholds 280 real z01,z02,z03 ! z0 thresholds 281 real tt_c,vv_c ! Critical param. 282 real tt_tmp,vv_tmp,vv_virt ! Temporary variables 283 real e_prad,e1pRad,A_Rad0,absg_V,absgnI,exdRad ! variables for SoSosv calculations 284 real zm1, zm2, coefslope ! variables for surface temperature extrapolation 285 ! for Aeolian erosion and blowing snow 286 integer nit ,iit 287 real Fac ! Correc. factor for drift ratio 288 real dusuth,signus 289 real sss__F,sss__N 290 real sss__K,sss__G 291 real us_127,us_227,us_327,us_427,us_527 292 real VVa_OK, usuth0 293 real ssstar 294 real SblPom 295 real rCd10n ! Square root of drag coefficient 296 real DendOK ! Dendricity Switch 297 real SaltOK ! Saltation Switch 298 real MeltOK ! Saltation Switch (Melting Snow) 299 real SnowOK ! Pack Top Switch 300 real SaltM1,SaltM2,SaltMo,SaltMx ! Saltation Parameters 301 real ShearX, ShearS ! Arg. Max Shear Stress 302 real Por_BS ! Snow Porosity 303 real Salt_us ! New thresh.friction velocity u*t 304 real Fac_Mo,ArguSi,FacRho ! Numerical factors for u*t 305 real SaltSI(klonv,0:nsno) ! Snow Drift Index ! 306 real MIN_Mo ! Minimum Mobility Fresh Fallen * 307 character*3 qsalt_param ! Switch for saltation flux param. 308 character*3 usth_param ! Switch for u*t param 309 310 311 ! Internal DATA 312 ! ============= 313 314 data T__Min / 200.00/ ! Minimum realistic Temperature 315 data TaPole / 268.15/ ! Maximum Polar Temperature (value from C. Agosta) 316 data roSMin / 300. / ! Minimum Snow Density 317 data roSMax / 400. / ! Max Fresh Snow Density 318 data tt_c / -2.0 / ! Critical Temp. (degC) 319 data vv_c / 14.3 / ! Critical Wind speed (m/s) 320 data roSn_1 / 109. / ! Fall.Sno.Density, Indep. Param. 321 data roSn_2 / 6. / ! Fall.Sno.Density, Temper.Param. 322 data roSn_3 / 26. / ! Fall.Sno.Density, Wind Param. 323 data Dendr1 / 17.12/ ! Fall.Sno.Dendric.,Wind 1/Param. 324 data Dendr2 / 128. / ! Fall.Sno.Dendric.,Wind 2/Param. 325 data Dendr3 / -20. / ! Fall.Sno.Dendric.,Indep. Param. 326 data Spher1 / 7.87/ ! Fall.Sno.Spheric.,Wind 1/Param. 327 data Spher2 / 38. / ! Fall.Sno.Spheric.,Wind 2/Param. 328 data Spher3 / 50. / ! Fall.Sno.Spheric.,Wind 3/Param. 329 data Spher4 / 90. / ! Fall.Sno.Spheric.,Indep. Param. 330 data EmiSol / 0.99999999/ ! 0.94Emissivity of Soil 331 data EmiWat / 0.99999999/ ! Emissivity of a Water Area 332 data EmiSno / 0.99999999/ ! Emissivity of Snow 333 334 335 ! DATA Emissivities ! Pielke, 1984, pp. 383,409 336 337 data Z0mBS0 / 0.5e-6/ ! MINimum Snow Roughness Length 338 ! for Momentum if Blowing Snow 339 ! Gallee et al. 2001 BLM 99 (19) 340 data Z0m_S0/ 0.00005/ ! MINimum Snow Roughness Length 341 ! MegaDunes included 342 data Z0m_S1/ 0.030 / ! MAXimum Snow Roughness Length 343 ! (Sastrugis) 344 c #GL data Z0_GIM/ 0.0013/ ! Ice Min Z0 = 0.0013 m (Broeke) 345 ! ! Old Ice Z0 = 0.0500 m (Bruce) 346 ! ! 0.0500 m (Smeets) 347 ! ! 0.1200 m (Broeke) 348 data Z0_ICE/ 0.0010/ ! Sea-Ice Z0 = 0.0010 m (Andreas) 349 ! ! (Ice Station Weddel -- ISW) 350 ! for aerolian erosion 351 data SblPom/ 1.27/ ! Lower Boundary Height Parameter 352 C + ! for Suspension 353 C + ! Pommeroy, Gray and Landine 1993, 354 C + ! J. Hydrology, 144(8) p.169 355 data nit / 5 / ! us(is0,uth) recursivity: Nb Iterations 356 cc#AE data qsalt_param/"bin"/ ! saltation part. conc. from Bintanja 2001 (p 357 data qsalt_param/"pom"/ ! saltation part. conc. from Pomeroy and Gray 358 cc#AE data usth_param/"lis"/ ! u*t from Liston et al. 2007 359 data usth_param/"gal"/ ! u*t from Gallee et al. 2001 360 data SaltMx/-5.83e-2/ 361 362 vk2 = vonKrm * vonKrm ! Square of Von Karman Constant 363 364 365 ! BEGIN.main. 366 ! =========================== 367 368 369 370 371 ! "Soil" Humidity of Water Bodies 372 ! =============================== 1 subroutine INLANDSIS(SnoMod,BloMod,jjtime,debut) 2 3 USE dimphy 4 5 !--------------------------------------------------------------------------+ 6 ! INLANDSIS module | 7 ! Simplified SISVAT module, containing ice and snow processes for | 8 ! ice-covered surfaces | 9 ! version MARv3, november 2020 | 10 ! SubRoutine INLANDSIS contains the fortran 77 code of the | 11 ! Soil/Ice Snow Vegetation Atmosphere Transfer Scheme | 12 ! | 13 !--------------------------------------------------------------------------+ 14 ! PARAMETERS: klonv: Total Number of columns = | 15 ! ^^^^^^^^^^ = Total Number of continental grid boxes | 16 ! X Number of Mosaic Cell per grid box | 17 ! | 18 ! INPUT: daHost : Date Host Model | 19 ! ^^^^^ | 20 ! | 21 ! INPUT: LSmask : 1: Land MASK | 22 ! ^^^^^ 0: Sea MASK | 23 ! isotSV = 0,...,12: Soil Type | 24 ! 0: Water, Liquid (Sea, Lake) | 25 ! 12: Water, Solid (Ice) | 26 ! | 27 ! INPUT: coszSV : Cosine of the Sun Zenithal Distance [-] | 28 ! ^^^^^ sol_SV : Surface Downward Solar Radiation [W/m2] | 29 ! IRd_SV : Surface Downward Longwave Radiation [W/m2] | 30 ! drr_SV : Rain Intensity [kg/m2/s] | 31 ! dsn_SV : Snow Intensity [mm w.e./s] | 32 ! dsnbSV : Snow Intensity, Drift Fraction [-] | 33 ! dbs_SV : Drift Amount [mm w.e.] | 34 ! za__SV : Surface Boundary Layer (SBL) Height [m] | 35 ! VV__SV :(SBL Top) Wind Velocity [m/s] | 36 ! TaT_SV : SBL Top Temperature [K] | 37 ! rhT_SV : SBL Top Air Density [kg/m3] | 38 ! QaT_SV : SBL Top Specific Humidity [kg/kg] | 39 ! qsnoSV : SBL Mean Snow Content [kg/kg] | 40 ! alb0SV : Soil Basic Albedo [-] | 41 ! slopSV : Surface Slope [-] | 42 ! dt__SV : Time Step [s] | 43 ! | 44 ! INPUT / isnoSV = total Nb of Ice/Snow Layers | 45 ! OUTPUT: ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer | 46 ! ^^^^^^ iiceSV = total Nb of Ice Layers | 47 ! istoSV = 0,...,5 : Snow History (see istdSV data) | 48 ! | 49 ! INPUT / alb_SV : Surface Albedo [-] | 50 ! OUTPUT: emi_SV : Surface Emissivity [-] | 51 ! ^^^^^^ IRs_SV : Soil IR Flux (negative) [W/m2] | 52 ! LMO_SV : Monin-Obukhov Scale [m] | 53 ! us__SV : Friction Velocity [m/s] | 54 ! uts_SV : Temperature Turbulent Scale [m/s] | 55 ! uqs_SV : Specific Humidity Velocity [m/s] | 56 ! uss_SV : Blowing Snow Turbulent Scale [m/s] | 57 ! usthSV : Blowing Snow Erosion Threshold [m/s] | 58 ! Z0m_SV : Momentum Roughness Length [m] | 59 ! Z0mmSV : Momentum Roughness Length (time mean) [m] | 60 ! Z0mnSV : Momentum Roughness Length (instantaneous)[m] | 61 ! Z0SaSV : Sastrugi Roughness Length [m] | 62 ! Z0e_SV : Erosion Snow Roughness Length [m] | 63 ! Z0emSV : Erosion Snow Roughness Length (time mean) [m] | 64 ! Z0enSV : Erosion Snow Roughness Length (instantaneous)[m] | 65 ! Z0roSV : Subgrid Topo Roughness Length [m] | 66 ! Z0h_SV : Heat Roughness Length [m] | 67 ! TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 68 ! & Snow Temperatures (layers 1,2,...,nsno) [K] | 69 ! ro__SV : Soil/Snow Volumic Mass [kg/m3] | 70 ! eta_SV : Soil/Snow Water Content [m3/m3] | 71 ! G1snSV : snow dendricity/sphericity | 72 ! G2snSV : snow sphericity/grain size | 73 ! dzsnSV : Snow Layer Thickness [m] | 74 ! agsnSV : Snow Age [day] | 75 ! BufsSV : Snow Buffer Layer [kg/m2] .OR. [mm] | 76 ! BrosSV : Snow Buffer Layer Density [kg/m3] | 77 ! BG1sSV : Snow Buffer Layer Dendricity / Sphericity [-] | 78 ! BG2sSV : Snow Buffer Layer Sphericity / Size [-] [0.1 mm] | 79 ! rusnSV : Surficial Water [kg/m2] .OR. [mm] | 80 ! | 81 ! OUTPUT: no__SV : OUTPUT file Unit Number [-] | 82 ! ^^^^^^ i___SV : OUTPUT point i Coordinate [-] | 83 ! j___SV : OUTPUT point j Coordinate [-] | 84 ! n___SV : OUTPUT point n Coordinate [-] | 85 ! lwriSV : OUTPUT point vec Index [-] | 86 ! | 87 ! OUTPUT: IRu_SV : Upward IR Flux (+, upw., effective) [K] | 88 ! ^^^^^^ hSalSV : Saltating Layer Height [m] | 89 ! qSalSV : Saltating Snow Concentration [kg/kg] | 90 ! RnofSV : RunOFF Intensity [kg/m2/s] | 91 ! | 92 ! Internal Variables: | 93 ! ^^^^^^^^^^^^^^^^^^ | 94 ! NLaysv = New Snow Layer Switch [-] | 95 ! albisv : Snow/Ice/Water/Soil Integrated Albedo [-] | 96 ! SoSosv : Absorbed Solar Radiation by Surfac.(Normaliz)[-] | 97 ! TBr_sv : Brightness Temperature [K] | 98 ! IRupsv : Upward IR Flux (-, upw.) [W/m2] | 99 ! ram_sv : Aerodynamic Resistance for Momentum [s/m] | 100 ! rah_sv : Aerodynamic Resistance for Heat [s/m] | 101 ! Evp_sv : Evaporation [kg/m2] | 102 ! EvT_sv : Evapotranspiration [kg/m2] | 103 ! HSs_sv : Surface Sensible Heat Flux + => absorb.[W/m2] | 104 ! HLs_sv : Surface Latent Heat Flux + => absorb.[W/m2] | 105 ! Lx_H2O : Latent Heat of Vaporization/Sublimation [J/kg] | 106 ! Tsrfsv : Surface Temperature [K] | 107 ! sEX_sv : Verticaly Integrated Extinction Coefficient [-] | 108 ! LSdzsv : Vertical Discretization Factor [-] | 109 ! = 1. Soil | 110 ! = 1000. Ocean | 111 ! z_snsv : Snow Pack Thickness [m] | 112 ! zzsnsv : Snow Pack Thickness [m] | 113 ! albssv : Soil Albedo [-] | 114 ! Eso_sv : Soil+Snow Emissivity [-] | 115 ! Khydsv : Soil Hydraulic Conductivity [m/s] | 116 ! | 117 ! ETSo_0 : Snow/Soil Energy Power, before Forcing [W/m2] | 118 ! ETSo_1 : Snow/Soil Energy Power, after Forcing [W/m2] | 119 ! ETSo_d : Snow/Soil Energy Power Forcing [W/m2] | 120 ! EqSn_0 : Snow Energy, before Phase Change [J/m2] | 121 ! EqSn_1 : Snow Energy, after Phase Change [J/m2] | 122 ! EqSn_d : Snow Energy, net Forcing [J/m2] | 123 ! Enrsvd : SVAT Energy Power Forcing [W/m2] | 124 ! Enrbal : SVAT Energy Balance [W/m2] | 125 ! Wats_0 : Soil Water, before Forcing [mm] | 126 ! Wats_1 : Soil Water, after Forcing [mm] | 127 ! Wats_d : Soil Water Forcing [mm] | 128 ! SIWm_0 : Snow initial Mass [mm w.e.] | 129 ! SIWm_1 : Snow final Mass [mm w.e.] | 130 ! SIWa_i : Snow Atmos. initial Forcing [mm w.e.] | 131 ! SIWa_f : Snow Atmos. final Forcing(noConsumed)[mm w.e.] | 132 ! SIWe_i : SnowErosion initial Forcing [mm w.e.] | 133 ! SIWe_f : SnowErosion final Forcing(noConsumed)[mm w.e.] | 134 ! SIsubl : Snow sublimed/deposed Mass [mm w.e.] | 135 ! SImelt : Snow Melted Mass [mm w.e.] | 136 ! SIrnof : Surficial Water + Run OFF Change [mm w.e.] | 137 ! SIvAcr : Sea-Ice vertical Acretion [mm w.e.] | 138 ! Watsvd : SVAT Water Forcing [mm] | 139 ! Watbal : SVAT Water Balance [W/m2] | 140 ! | 141 ! vk2 : Square of Von Karman Constant [-] | 142 ! sqrCm0 : Factor of Neutral Drag Coeffic.Momentum [s/m] | 143 ! sqrCh0 : Factor of Neutral Drag Coeffic.Heat [s/m] | 144 ! EmiSol : Soil Emissivity [-] | 145 ! EmiSno : Snow Emissivity [-] | 146 ! EmiWat : Water Emissivity [-] | 147 ! Z0mLnd : Land Roughness Length [m] | 148 ! sqrrZ0 : u*t/u* | 149 ! f_eff : Marticorena & B. 1995 JGR (20) | 150 ! A_Fact : Fundamental * Roughness | 151 ! Z0mBSn : BSnow Roughness Length [m] | 152 ! Z0mBS0 : Mimimum BSnow Roughness Length (blown* ) [m] | 153 ! Z0m_Sn : Snow Roughness Length (surface) [m] | 154 ! Z0m_S0 : Mimimum Snow Roughness Length [m] | 155 ! Z0m_S1 : Maximum Snow Roughness Length [m] | 156 ! Z0_GIM : Minimum GIMEX Roughness Length [m] | 157 ! Z0_ICE : Sea Ice ISW Roughness Length [m] | 158 ! | 159 ! | 160 !--------------------------------------------------------------------------+ 161 162 163 164 ! Global Variables 165 ! ================ 166 167 168 USE VARphy 169 USE VAR_SV 170 USE VARdSV 171 USE VAR0SV 172 USE VARxSV 173 USE VARySV 174 USE VARtSV 175 USE surface_data, ONLY: is_ok_z0h_rn, & 176 is_ok_density_kotlyakov, & 177 prescribed_z0m_snow, & 178 iflag_z0m_snow, & 179 iflag_tsurf_inlandsis, & 180 iflag_temp_inlandsis, & 181 discret_xf, buf_sph_pol,buf_siz_pol 182 183 IMPLICIT NONE 184 185 logical :: SnoMod 186 logical :: BloMod 187 logical :: debut 188 integer :: jjtime 189 190 191 ! Internal Variables 192 ! ================== 193 194 ! Non Local 195 ! --------- 196 197 real :: TBr_sv(klonv) ! Brightness Temperature 198 real :: IRdwsv(klonv) ! DOWNward IR Flux 199 real :: IRupsv(klonv) ! UPward IR Flux 200 real :: d_Bufs,Bufs_N ! Buffer Snow Layer Increment 201 real :: Buf_ro,Bros_N ! Buffer Snow Layer Density 202 real :: BufPro ! Buffer Snow Layer Density 203 real :: Buf_G1,BG1__N ! Buffer Snow Layer Dendr/Sphe[-] 204 real :: Buf_G2,BG2__N ! Buffer Snow Layer Spher/Size[-] 205 real :: Bdzssv(klonv) ! Buffer Snow Layer Thickness 206 real :: z_snsv(klonv) ! Snow-Ice, current Thickness 207 208 209 210 ! Local 211 ! ----- 212 213 integer :: iwr 214 integer :: ikl ,isn ,isl ,ist ! 215 integer :: ist__s,ist__w ! Soil/Water Body Identifier 216 integer :: growth ! Seasonal Mask 217 integer :: LISmsk ! Land+Ice / Open Sea Mask 218 integer :: LSnMsk ! Snow-Ice / No Snow-Ice Mask 219 integer :: IceMsk,IcIndx(klonv) ! Ice / No Ice Mask 220 integer :: SnoMsk ! Snow / No Snow Mask 221 real :: roSMin,roSMax,roSn_1,roSn_2,roSn_3 ! Fallen Snow Density (PAHAUT) 222 real :: Dendr1,Dendr2,Dendr3 ! Fallen Snow Dendric.(GIRAUD) 223 real :: Spher1,Spher2,Spher3,Spher4 ! Fallen Snow Spheric.(GIRAUD) 224 real :: Polair ! Polar Snow Switch 225 real :: PorSno,Salt_f,PorRef ! 226 ! #sw real PorVol,rWater ! 227 ! #sw real rusNEW,rdzNEW,etaNEW ! 228 real :: ro_new ! 229 real :: TaPole ! Maximum Polar Temperature 230 real :: T__Min ! Minimum realistic Temperature 231 real :: EmiSol ! Emissivity of Soil 232 real :: EmiSno ! Emissivity of Snow 233 real :: EmiWat ! Emissivity of a Water Area 234 real :: vk2 ! Square of Von Karman Constant 235 real :: u2star !(u*)**2 236 real :: Z0mLnd ! Land Roughness Length 237 ! #ZN real sqrrZ0 ! u*t/u* 238 real :: f_eff ! Marticorena & B. 1995 JGR (20) 239 real :: A_Fact ! Fundamental * Roughness 240 real :: Z0m_nu ! Smooth R Snow Roughness Length 241 real :: Z0mBSn ! BSnow Roughness Length 242 real :: Z0mBS0 ! Mimimum BSnow Roughness Length 243 real :: Z0m_S0 ! Mimimum Snow Roughness Length 244 real :: Z0m_S1 ! Maximum Snow Roughness Length 245 ! #SZ real Z0Sa_N ! Regime Snow Roughness Length 246 ! #SZ real Z0SaSi ! 1.IF Rgm Snow Roughness Length 247 ! #GL real Z0_GIM ! Mimimum GIMEX Roughness Length 248 real :: Z0_ICE ! Ice ISW Roughness Length 249 real :: Z0m_Sn,Z0m_90 ! Snow Surface Roughness Length 250 real :: SnoWat ! Snow Layer Switch 251 real :: rstar,alors ! 252 real :: rstar0,rstar1,rstar2 ! 253 real :: SameOK ! 1. => Same Type of Grains 254 real :: G1same ! Averaged G1, same Grains 255 real :: G2same ! Averaged G2, same Grains 256 real :: typ__1 ! 1. => Lay1 Type: Dendritic 257 real :: zroNEW ! dz X ro, if fresh Snow 258 real :: G1_NEW ! G1, if fresh Snow 259 real :: G2_NEW ! G2, if fresh Snow 260 real :: zroOLD ! dz X ro, if old Snow 261 real :: G1_OLD ! G1, if old Snow 262 real :: G2_OLD ! G2, if old Snow 263 real :: SizNEW ! Size, if fresh Snow 264 real :: SphNEW ! Spheric.,if fresh Snow 265 real :: SizOLD ! Size, if old Snow 266 real :: SphOLD ! Spheric.,if old Snow 267 real :: Siz_av ! Averaged Grain Size 268 real :: Sph_av ! Averaged Grain Spher. 269 real :: Den_av ! Averaged Grain Dendr. 270 real :: G1diff ! Averaged G1, diff. Grains 271 real :: G2diff ! Averaged G2, diff. Grains 272 real :: G1 ! Averaged G1 273 real :: G2 ! Averaged G2 274 real :: param ! Polynomial fit z0=f(T) 275 real :: Z0_obs ! Fit Z0_obs=f(T) (m) 276 real :: tamin ! min T of linear fit (K) 277 real :: tamax ! max T of linear fit (K) 278 real :: coefa,coefb,coefc,coefd ! Coefs for z0=f(T) 279 real :: ta1,ta2,ta3 ! Air temperature thresholds 280 real :: z01,z02,z03 ! z0 thresholds 281 real :: tt_c,vv_c ! Critical param. 282 real :: tt_tmp,vv_tmp,vv_virt ! Temporary variables 283 real :: e_prad,e1pRad,A_Rad0,absg_V,absgnI,exdRad ! variables for SoSosv calculations 284 real :: zm1, zm2, coefslope ! variables for surface temperature extrapolation 285 ! for Aeolian erosion and blowing snow 286 integer :: nit ,iit 287 real :: Fac ! Correc. factor for drift ratio 288 real :: dusuth,signus 289 real :: sss__F,sss__N 290 real :: sss__K,sss__G 291 real :: us_127,us_227,us_327,us_427,us_527 292 real :: VVa_OK, usuth0 293 real :: ssstar 294 real :: SblPom 295 real :: rCd10n ! Square root of drag coefficient 296 real :: DendOK ! Dendricity Switch 297 real :: SaltOK ! Saltation Switch 298 real :: MeltOK ! Saltation Switch (Melting Snow) 299 real :: SnowOK ! Pack Top Switch 300 real :: SaltM1,SaltM2,SaltMo,SaltMx ! Saltation Parameters 301 real :: ShearX, ShearS ! Arg. Max Shear Stress 302 real :: Por_BS ! Snow Porosity 303 real :: Salt_us ! New thresh.friction velocity u*t 304 real :: Fac_Mo,ArguSi,FacRho ! Numerical factors for u*t 305 real :: SaltSI(klonv,0:nsno) ! Snow Drift Index ! 306 real :: MIN_Mo ! Minimum Mobility Fresh Fallen * 307 character(len=3) :: qsalt_param ! Switch for saltation flux param. 308 character(len=3) :: usth_param ! Switch for u*t param 309 310 311 ! Internal DATA 312 ! ============= 313 314 data T__Min / 200.00/ ! Minimum realistic Temperature 315 data TaPole / 268.15/ ! Maximum Polar Temperature (value from C. Agosta) 316 data roSMin / 300. / ! Minimum Snow Density 317 data roSMax / 400. / ! Max Fresh Snow Density 318 data tt_c / -2.0 / ! Critical Temp. (degC) 319 data vv_c / 14.3 / ! Critical Wind speed (m/s) 320 data roSn_1 / 109. / ! Fall.Sno.Density, Indep. Param. 321 data roSn_2 / 6. / ! Fall.Sno.Density, Temper.Param. 322 data roSn_3 / 26. / ! Fall.Sno.Density, Wind Param. 323 data Dendr1 / 17.12/ ! Fall.Sno.Dendric.,Wind 1/Param. 324 data Dendr2 / 128. / ! Fall.Sno.Dendric.,Wind 2/Param. 325 data Dendr3 / -20. / ! Fall.Sno.Dendric.,Indep. Param. 326 data Spher1 / 7.87/ ! Fall.Sno.Spheric.,Wind 1/Param. 327 data Spher2 / 38. / ! Fall.Sno.Spheric.,Wind 2/Param. 328 data Spher3 / 50. / ! Fall.Sno.Spheric.,Wind 3/Param. 329 data Spher4 / 90. / ! Fall.Sno.Spheric.,Indep. Param. 330 data EmiSol / 0.99999999/ ! 0.94Emissivity of Soil 331 data EmiWat / 0.99999999/ ! Emissivity of a Water Area 332 data EmiSno / 0.99999999/ ! Emissivity of Snow 333 334 335 ! DATA Emissivities ! Pielke, 1984, pp. 383,409 336 337 data Z0mBS0 / 0.5e-6/ ! MINimum Snow Roughness Length 338 ! ! for Momentum if Blowing Snow 339 ! ! Gallee et al. 2001 BLM 99 (19) 340 data Z0m_S0/ 0.00005/ ! MINimum Snow Roughness Length 341 ! ! MegaDunes included 342 data Z0m_S1/ 0.030 / ! MAXimum Snow Roughness Length 343 ! ! (Sastrugis) 344 ! #GL data Z0_GIM/ 0.0013/ ! Ice Min Z0 = 0.0013 m (Broeke) 345 ! ! Old Ice Z0 = 0.0500 m (Bruce) 346 ! ! 0.0500 m (Smeets) 347 ! ! 0.1200 m (Broeke) 348 data Z0_ICE/ 0.0010/ ! Sea-Ice Z0 = 0.0010 m (Andreas) 349 ! ! (Ice Station Weddel -- ISW) 350 ! for aerolian erosion 351 data SblPom/ 1.27/ ! Lower Boundary Height Parameter 352 ! + ! for Suspension 353 ! + ! Pommeroy, Gray and Landine 1993, 354 ! + ! J. Hydrology, 144(8) p.169 355 data nit / 5 / ! us(is0,uth) recursivity: Nb Iterations 356 !c#AE data qsalt_param/"bin"/ ! saltation part. conc. from Bintanja 2001 (p 357 data qsalt_param/"pom"/ ! saltation part. conc. from Pomeroy and Gray 358 !c#AE data usth_param/"lis"/ ! u*t from Liston et al. 2007 359 data usth_param/"gal"/ ! u*t from Gallee et al. 2001 360 data SaltMx/-5.83e-2/ 361 362 vk2 = vonKrm * vonKrm ! Square of Von Karman Constant 363 364 365 ! BEGIN.main. 366 ! =========================== 367 368 369 370 371 ! "Soil" Humidity of Water Bodies 372 ! =============================== 373 374 DO ikl=1,knonv 375 376 ist = isotSV(ikl) ! Soil Type 377 ist__s = min(ist, 1) ! 1 => Soil 378 ist__w = 1 - ist__s ! 1 => Water Body 379 DO isl=-nsol,0 380 eta_SV(ikl,isl) = eta_SV(ikl,isl) * ist__s & ! Soil 381 + etadSV(ist) * ist__w ! Water Body 382 END DO 383 384 385 ! Vertical Discretization Factor 386 ! ============================== 387 388 LSdzsv(ikl) = ist__s & ! Soil 389 + OcndSV * ist__w ! Water Body 390 END DO 391 392 393 394 395 396 IF (SnoMod) THEN 397 398 399 ! +--Aeolian erosion and Blowing Snow 400 ! +================================== 401 402 403 404 DO ikl=1,knonv 405 usthSV(ikl) = 1.0e+2 406 END DO 407 408 409 IF (BloMod) THEN 410 411 if (klonv.eq.1) then 412 if(isnoSV(1).ge.2 .and. & 413 TsisSV(1,max(1,isnoSV(1)))<273. .and. & 414 ro__SV(1,max(1,isnoSV(1)))<500. .and. & 415 eta_SV(1,max(1,isnoSV(1)))<epsi) then 416 ! + ********** 417 call SISVAT_BSn 418 endif 419 else 420 call SISVAT_BSn 421 ! + ********** 422 endif 423 424 425 426 427 428 429 430 ! Calculate threshold erosion velocity for next time step 431 ! Unlike in sisvat, computation is of threshold velocity made here (instead of sisvaesbl) 432 ! since we do not use sisvatesbl for the coupling with LMDZ 433 434 ! +--Computation of threshold friction velocity for snow erosion 435 ! --------------------------------------------------------------- 436 437 rCd10n = 1. / 26.5 ! Vt / u*t = 26.5 438 ! ! Budd et al. 1965, Antarct. Res. Series Fig.13 439 ! ! ratio developped during assumed neutral conditions 440 441 442 ! +--Snow Properties 443 ! + ~~~~~~~~~~~~~~~ 444 445 DO ikl = 1,knonv 446 447 isn = isnoSV(ikl) 448 449 450 451 DendOK = max(zero,sign(unun,epsi-G1snSV(ikl,isn) )) ! 452 SaltOK = min(1 , max(istdSV(2)-istoSV(ikl,isn),0)) ! 453 MeltOK = (unun & ! 454 -max(zero,sign(unun,TfSnow-epsi & ! 455 -TsisSV(ikl,isn) ))) & ! Melting Snow 456 * min(unun,DendOK & ! 457 +(1.-DendOK) & ! 458 *sign(unun, G2snSV(ikl,isn)-1.0)) ! 1.0 for 1mm 459 SnowOK = min(1 , max(isnoSV(ikl) +1 -isn ,0)) ! Snow Switch 460 461 G1snSV(ikl,isn) = SnowOK * G1snSV(ikl,isn) & 462 + (1.- SnowOK)*min(G1snSV(ikl,isn),G1_dSV) 463 G2snSV(ikl,isn) = SnowOK * G2snSV(ikl,isn) & 464 + (1.- SnowOK)*min(G2snSV(ikl,isn),G1_dSV) 465 466 SaltOK = min(unun, SaltOK + MeltOK) * SnowOK 467 468 469 ! +--Mobility Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.) 470 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 471 SaltM1 = -0.750e-2 * G1snSV(ikl,isn) & 472 -0.500e-2 * G2snSV(ikl,isn)+ 0.500e00 !dendritic case 473 ! + CAUTION: Guyomarc'h & Merindol Dendricity Sign is + 474 ! + ^^^^^^^^ MAR Dendricity Sign is - 475 SaltM2 = -0.833d-2 * G1snSV(ikl,isn) & 476 -0.583d-2 * G2snSV(ikl,isn)+ 0.833d00 !non-dendritic case 477 478 ! SaltMo = (DendOK * SaltM1 + (1.-DendOK) * SaltM2 ) 479 SaltMo = 0.625 !SaltMo pour d=s=0.5 480 481 !weighting SaltMo with surface snow density (Vionnet et al. 2012) 482 !c#AE FacRho = 1.25 - 0.0042 * ro__SV(ikl,isn) 483 !c#AE SaltMo = 0.34 * SaltMo + 0.66 * FacRho !needed for polar snow 484 MIN_Mo = 0. 485 ! SaltMo = max(SaltMo,MIN_Mo) 486 ! SaltMo = SaltOK * SaltMo + (1.-SaltOK) * min(SaltMo,SaltMx) 487 ! #TUNE SaltMo = SaltOK * SaltMo - (1.-SaltOK) * 0.9500 488 SaltMo = max(SaltMo,epsi-unun) 489 490 ! +--Influence of Density on Threshold Shear Stress 491 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 492 Por_BS = 1. - 300. / ro_Ice 493 ShearS = Por_BS / (1.-Por_BS) 494 ! +... SheaBS = Arg(sqrt(shear = max shear stress in snow)): 495 ! + shear = 3.420d00 * exp(-(Por_BS +Por_BS) 496 ! + . /(unun -Por_BS)) 497 ! + SheaBS : see de Montmollin (1978), 498 ! + These Univ. Sci. Medic. Grenoble, Fig. 1 p. 124 499 500 ! +--Snow Drift Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.) 501 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 502 ArguSi = -0.085 *us__SV(ikl)/rCd10n 503 !V=u*/sqrt(CD) eqs 2 to 4 Gallee et al. 2001 504 505 SaltSI(ikl,isn) = -2.868 * exp(ArguSi) + 1 + SaltMo 506 507 508 ! +--Threshold Friction Velocity 509 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 510 if(ro__SV(ikl,isn)>300.) then 511 Por_BS = 1.000 - ro__SV(ikl,isn) /ro_Ice 512 else 513 Por_BS = 1.000 - 300. /ro_Ice 514 endif 515 516 ShearX = Por_BS/max(epsi,1.-Por_BS) 517 Fac_Mo = exp(-ShearX+ShearS) 518 ! + Gallee et al., 2001 eq 5, p5 519 520 if (usth_param .eq. "gal") then 521 Salt_us = (log(2.868) - log(1 + SaltMo)) * rCd10n/0.085 522 Salt_us = Salt_us * Fac_Mo 523 ! +... Salt_us : Extension of Guyomarc'h & Merindol 1998 with 524 ! +... de Montmollin (1978). Gallee et al. 2001 525 endif 526 527 if (usth_param .eq. "lis") then !Liston et al. 2007 528 if(ro__SV(ikl,isn)>300.) then 529 Salt_us = 0.005*exp(0.013*ro__SV(ikl,isn)) 530 else 531 Salt_us = 0.01*exp(0.003*ro__SV(ikl,isn)) 532 endif 533 endif 534 535 SnowOK = 1 -min(1,iabs(isn-isnoSV(ikl))) !Switch new vs old snow 536 537 usthSV(ikl) = SnowOK * (Salt_us) & 538 + (1.-SnowOK)* usthSV(ikl) 539 540 END DO 541 542 543 544 ! Feeback between blowing snow turbulent Scale u* (commented here 545 ! since ustar is an input variable (not in/out) of inlandsis) 546 ! ----------------------------------------------------------------- 547 548 549 ! VVa_OK = max(0.000001, VVaSBL(ikl)) 550 ! sss__N = vonkar * VVa_OK 551 ! sss__F = (sqrCm0(ikl) - psim_z + psim_0) 552 ! usuth0 = sss__N /sss__F ! u* if NO Blow. Snow 553 554 ! sss__G = 0.27417 * gravit 555 556 ! ! ______________ _____ 557 ! ! Newton-Raphson (! Iteration, BEGIN) 558 ! ! ~~~~~~~~~~~~~~ ~~~~~ 559 ! DO iit=1,nit 560 ! sss__K = gravit * r_Turb * A_Turb *za__SV(ikl) 561 ! . *rCDmSV(ikl)*rCDmSV(ikl) 562 ! . /(1.+0.608*QaT_SV(ikl)-qsnoSV(ikl)) 563 ! us_127 = exp( SblPom *log(us__SV(ikl))) 564 ! us_227 = us_127 * us__SV(ikl) 565 ! us_327 = us_227 * us__SV(ikl) 566 ! us_427 = us_327 * us__SV(ikl) 567 ! us_527 = us_427 * us__SV(ikl) 568 569 ! us__SV(ikl) = us__SV(ikl) 570 ! . - ( us_527 *sss__F /sss__N 571 ! . - us_427 572 ! . - us_227 *qsnoSV(ikl)*sss__K 573 ! . + (us__SV(ikl)*us__SV(ikl)-usthSV(ikl)*usthSV(ikl))/sss__G) 574 ! . /( us_427*5.27*sss__F /sss__N 575 ! . - us_327*4.27 576 ! . - us_127*2.27*qsnoSV(ikl)*sss__K 577 ! . + us__SV(ikl)*2.0 /sss__G) 578 579 ! us__SV(ikl)= min(us__SV(ikl),usuth0) 580 ! us__SV(ikl)= max(us__SV(ikl),epsi ) 581 ! rCDmSV(ikl)= us__SV(ikl)/VVa_OK 582 ! ! #AE sss__F = vonkar /rCDmSV(ikl) 583 ! ENDDO 584 585 ! ! ______________ ___ 586 ! ! Newton-Raphson (! Iteration, END ) 587 ! ! ~~~~~~~~~~~~~~ ~~~ 588 589 ! us_127 = exp( SblPom *log(us__SV(ikl))) 590 ! us_227 = us_127 * us__SV(ikl) 591 592 ! ! Momentum Turbulent Scale u*: 0-Limit in case of no Blow. Snow 593 ! ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 594 ! dusuth = us__SV(ikl) - usthSV(ikl) ! u* - uth* 595 ! signus = max(sign(unun,dusuth),zero) ! 1 <=> u* - uth* > 0 596 ! us__SV(ikl) = ! 597 ! . us__SV(ikl) *signus + ! u* (_BS) 598 ! . usuth0 ! u* (nBS) 599 ! . *(1.-signus) ! 600 601 602 603 604 ! Blowing Snow Turbulent Scale ss* 605 ! --------------------------------------- 606 607 hSalSV(ikl) = 8.436e-2 * us__SV(ikl)**SblPom 608 609 if (qsalt_param .eq. "pom") then 610 qSalSV(ikl) = (us__SV(ikl)**2 - usthSV(ikl)**2) *signus & 611 / (hSalSV(ikl) * gravit * us__SV(ikl) * 3.25) 612 endif 613 614 if (qsalt_param .eq. "bin") then 615 qSalSV(ikl) = (us__SV(ikl) * us__SV(ikl) & 616 -usthSV(ikl) * usthSV(ikl))*signus & 617 * 0.535 / (hSalSV(ikl) * gravit) 618 endif 619 620 qSalSV(ikl) = qSalSV(ikl)/rht_SV(ikl) ! conversion kg/m3 to kg/kg 621 622 ssstar = rCDmSV(ikl) * (qsnoSV(ikl) - qSalSV(ikl)) & 623 * r_Turb !Bintanja 2000, BLM 624 !r_Turb compensates for an overestim. of the blown snow part. fall velocity 625 626 uss_SV(ikl) = min(zero , us__SV(ikl) *ssstar) 627 uss_SV(ikl) = max(-0.0001 , uss_SV(ikl)) 628 629 630 631 632 ENDIF ! BloMod 633 634 ! + ------------------------------------------------------ 635 ! +--Buffer Layer 636 ! + ----------------------------------------------------- 373 637 374 638 DO ikl=1,knonv 375 376 ist = isotSV(ikl) ! Soil Type 377 ist__s = min(ist, 1) ! 1 => Soil 378 ist__w = 1 - ist__s ! 1 => Water Body 379 DO isl=-nsol,0 380 eta_SV(ikl,isl) = eta_SV(ikl,isl) * ist__s ! Soil 381 . + etadSV(ist) * ist__w ! Water Body 382 END DO 383 384 385 ! Vertical Discretization Factor 386 ! ============================== 387 388 LSdzsv(ikl) = ist__s ! Soil 389 . + OcndSV * ist__w ! Water Body 639 ! BufsSV(ikl) [mm w.e.] i.e, i.e., [kg/m2] 640 d_Bufs = max(dsn_SV(ikl) *dt__SV,0.) ! 641 dsn_SV(ikl) = 0. ! 642 Bufs_N = BufsSV(ikl) +d_Bufs ! 643 644 645 ! +--Snow Density 646 ! + ^^^^^^^^^^^^ 647 Polair = zero 648 ! #NP Polair = max(zero, ! 649 ! #NP. sign(unun,TaPole ! 650 ! #NP. -TaT_SV(ikl))) ! 651 Polair = max(zero, & ! 652 sign(unun,TaPole & ! 653 -TaT_SV(ikl))) ! 654 Buf_ro = max( rosMin, & ! Fallen Snow Density 655 roSn_1+roSn_2* (TaT_SV(ikl)-TfSnow) & ! [kg/m3] 656 +roSn_3*sqrt( VV__SV(ikl))) ! Pahaut (CEN), Etienne: use wind speed at first model level instead of 10m wind 657 ! #NP BufPro = max( rosMin, ! Fallen Snow Density 658 ! #NP. 104. *sqrt( max( VV10SV(ikl)-6.0,0.0))) ! Kotlyakov (1961) 659 660 ! C.Agosta option for snow density, same as for BS i.e. 661 ! is_ok_density_kotlyakov=.false. 662 ! #BS density_kotlyakov = .false. !C.Amory BS 2018 663 ! + ... Fallen Snow Density, Adapted for Antarctica 664 if (is_ok_density_kotlyakov) then 665 tt_tmp = TaT_SV(ikl)-TfSnow 666 ! !vv_tmp = VV10SV(ikl) 667 vv_tmp=VV__SV(ikl) ! Etienne: use wind speed at first model level instead of 10m wind 668 ! + ... [ A compromise between 669 ! + ... Kotlyakov (1961) and Lenaerts (2012, JGR, Part1) ] 670 if (tt_tmp.ge.-10) then 671 BufPro = max( rosMin, & 672 104. *sqrt( max( vv_tmp-6.0,0.0))) ! Kotlyakov (1961) 673 else 674 vv_virt = (tt_c*vv_tmp+vv_c*(tt_tmp+10)) & 675 /(tt_c+tt_tmp+10) 676 BufPro = 104. *sqrt( max( vv_virt-6.0,0.0)) 677 endif 678 else 679 ! + ... [ density derived from observations of the first 50cm of 680 ! + ... snow - cf. Rajashree Datta - and multiplied by 0.8 ] 681 ! + ... C. Agosta, 2016-09 682 !c #SD BufPro = 149.2 + 6.84*VV10SV(ikl) + 0.48*Tsrfsv(ikl) 683 !c #SD BufPro = 125 + 14*VV10SV(ikl) + 0.6*Tsrfsv(ikl) !MAJ CK and CAm 684 ! BufPro = 200 + 21 * VV10SV(ikl)!CK 29/07/19 685 BufPro = 200 + 21 * VV__SV(ikl)!Etienne: use wind speed at first model level instead of 10m wind 686 endif 687 688 Bros_N = (1. - Polair) * Buf_ro & ! Temperate Snow 689 + Polair * BufPro ! Polar Snow 690 691 Bros_N = max( 20.,max(rosMin, Bros_N)) 692 Bros_N = min(400.,min(rosMax-1,Bros_N)) ! for dz_min in SISVAT_zSn 693 694 695 ! Density of deposited blown snow 696 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 697 698 if (BloMod) then 699 Bros_N = frsno 700 ro_new = ro__SV(ikl,max(1,isnoSV(ikl))) 701 ro_new = max(Bros_N,min(roBdSV,ro_new)) 702 Fac = 1-((ro__SV(ikl,max(1,isnoSV(ikl))) & 703 -roBdSV)/(500.-roBdSV)) 704 Fac = max(0.,min(1.,Fac)) 705 dsnbSV(ikl) = Fac*dsnbSV(ikl) 706 Bros_N = Bros_N * (1.0-dsnbSV(ikl)) & 707 + ro_new * dsnbSV(ikl) 708 endif 709 710 711 ! Time averaged Density of deposited blown Snow 712 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 713 714 BrosSV(ikl) =(Bros_N * d_Bufs & ! 715 +BrosSV(ikl)* BufsSV(ikl)) & ! 716 / max(epsi,Bufs_N) ! 717 718 719 ! +-- S.Falling Snow Properties (computed as in SISVAT_zAg) 720 ! + ^^^^^^^^^^^^^^^^^^^^^^^ 721 Buf_G1 = max(-G1_dSV, & ! Temperate Snow 722 min(Dendr1*VV__SV(ikl)-Dendr2, & ! Dendricity 723 Dendr3 )) ! 724 Buf_G2 = min( Spher4, & ! Temperate Snow 725 max(Spher1*VV__SV(ikl)+Spher2, & ! Sphericity 726 Spher3 )) ! 727 ! EV: now control buf_sph_pol and bug_siz_pol in physiq.def 728 Buf_G1 = (1. - Polair) * Buf_G1 & ! Temperate Snow 729 + Polair * buf_sph_pol ! Polar Snow 730 Buf_G2 = (1. - Polair) * Buf_G2 & ! Temperate Snow 731 + Polair * buf_siz_pol ! Polar Snow 732 G1 = Buf_G1 ! NO Blown Snow 733 G2 = Buf_G2 ! NO Blown Snow 734 735 736 737 IF (BloMod) THEN 738 739 ! S.1. Meme Type de Neige / same Grain Type 740 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 741 742 SameOK = max(zero, & 743 sign(unun, Buf_G1 *G1_dSV & 744 - eps_21 )) 745 G1same = ((1.0-dsnbSV(ikl))*Buf_G1+dsnbSV(ikl) *G1_dSV) 746 G2same = ((1.0-dsnbSV(ikl))*Buf_G2+dsnbSV(ikl) *ADSdSV) 747 ! Blowing Snow Properties: G1_dSV, ADSdSV 748 749 ! S.2. Types differents / differents Types 750 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 751 typ__1 = max(zero,sign(unun,epsi-Buf_G1)) ! =1.=> Dendritic 752 zroNEW = typ__1 *(1.0-dsnbSV(ikl)) & ! fract.Dendr.Lay. 753 + (1.-typ__1) * dsnbSV(ikl) ! 754 G1_NEW = typ__1 *Buf_G1 & ! G1 of Dendr.Lay. 755 + (1.-typ__1) *G1_dSV ! 756 G2_NEW = typ__1 *Buf_G2 & ! G2 of Dendr.Lay. 757 + (1.-typ__1) *ADSdSV ! 758 zroOLD = (1.-typ__1) *(1.0-dsnbSV(ikl)) & ! fract.Spher.Lay. 759 + typ__1 * dsnbSV(ikl) ! 760 G1_OLD = (1.-typ__1) *Buf_G1 & ! G1 of Spher.Lay. 761 + typ__1 *G1_dSV ! 762 G2_OLD = (1.-typ__1) *Buf_G2 & ! G2 of Spher.Lay. 763 + typ__1 *ADSdSV ! 764 SizNEW = -G1_NEW *DDcdSV/G1_dSV & ! Size Dendr.Lay. 765 +(1.+G1_NEW /G1_dSV) & ! 766 *(G2_NEW *DScdSV/G1_dSV & ! 767 +(1.-G2_NEW /G1_dSV)*DFcdSV) ! 768 SphNEW = G2_NEW /G1_dSV ! Spher.Dendr.Lay. 769 SizOLD = G2_OLD ! Size Spher.Lay. 770 SphOLD = G1_OLD /G1_dSV ! Spher.Spher.Lay. 771 Siz_av = (zroNEW*SizNEW+zroOLD*SizOLD) ! Averaged Size 772 Sph_av = min( zroNEW*SphNEW+zroOLD*SphOLD & ! 773 , unun) ! Averaged Sphericity 774 Den_av = min((Siz_av -( Sph_av *DScdSV & ! 775 +(1.-Sph_av)*DFcdSV)) & ! 776 / (DDcdSV -( Sph_av *DScdSV & ! 777 +(1.-Sph_av)*DFcdSV)) & ! 778 , unun) ! 779 DendOK = max(zero, & ! 780 sign(unun, Sph_av *DScdSV & ! Small Grains 781 +(1.-Sph_av)*DFcdSV & ! Faceted Grains 782 - Siz_av )) ! 783 ! +... REMARQUE: le type moyen (dendritique ou non) depend 784 ! + ^^^^^^^^ de la comparaison avec le diametre optique 785 ! + d'une neige recente de dendricite nulle 786 ! +... REMARK: the mean type (dendritic or not) depends 787 ! + ^^^^^^ on the comparaison with the optical diameter 788 ! + of a recent snow having zero dendricity 789 790 G1diff =( -DendOK *Den_av & 791 +(1.-DendOK)*Sph_av) *G1_dSV 792 G2diff = DendOK *Sph_av *G1_dSV & 793 +(1.-DendOK)*Siz_av 794 G1 = SameOK *G1same & 795 +(1.-SameOK)*G1diff 796 G2 = SameOK *G2same & 797 +(1.-SameOK)*G2diff 798 ENDIF 799 800 801 802 ! S.1. Meme Type de Neige / same Grain Type 803 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 804 SameOK = max(zero, & 805 sign(unun, Buf_G1 *BG1sSV(ikl) & 806 - eps_21 )) 807 G1same = (d_Bufs*Buf_G1+BufsSV(ikl)*BG1sSV(ikl)) & 808 /max(epsi,Bufs_N) 809 G2same = (d_Bufs*Buf_G2+BufsSV(ikl)*BG2sSV(ikl)) & 810 /max(epsi,Bufs_N) 811 812 ! S.2. Types differents / differents Types 813 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 814 815 typ__1 = max(zero,sign(unun,epsi-Buf_G1)) ! =1.=> Dendritic 816 zroNEW =( typ__1 *d_Bufs & ! fract.Dendr.Lay. 817 + (1.-typ__1) *BufsSV(ikl)) & ! 818 /max(epsi,Bufs_N) ! 819 G1_NEW = typ__1 *Buf_G1 & ! G1 of Dendr.Lay. 820 + (1.-typ__1) *BG1sSV(ikl) ! 821 G2_NEW = typ__1 *Buf_G2 & ! G2 of Dendr.Lay. 822 + (1.-typ__1) *BG2sSV(ikl) ! 823 zroOLD =((1.-typ__1) *d_Bufs & ! fract.Spher.Lay. 824 + typ__1 *BufsSV(ikl)) & ! 825 /max(epsi,Bufs_N) ! 826 G1_OLD = (1.-typ__1) *Buf_G1 & ! G1 of Spher.Lay. 827 + typ__1 *BG1sSV(ikl) ! 828 G2_OLD = (1.-typ__1) *Buf_G2 & ! G2 of Spher.Lay. 829 + typ__1 *BG2sSV(ikl) ! 830 SizNEW = -G1_NEW *DDcdSV/G1_dSV & ! Size Dendr.Lay. 831 +(1.+G1_NEW /G1_dSV) & ! 832 *(G2_NEW *DScdSV/G1_dSV & ! 833 +(1.-G2_NEW /G1_dSV)*DFcdSV) ! 834 SphNEW = G2_NEW /G1_dSV ! Spher.Dendr.Lay. 835 SizOLD = G2_OLD ! Size Spher.Lay. 836 SphOLD = G1_OLD /G1_dSV ! Spher.Spher.Lay. 837 Siz_av = ( zroNEW *SizNEW+zroOLD*SizOLD) ! Averaged Size 838 Sph_av = min( zroNEW *SphNEW+zroOLD*SphOLD & ! 839 , unun ) ! Averaged Sphericity 840 Den_av = min((Siz_av - ( Sph_av *DScdSV & ! 841 +(1.-Sph_av)*DFcdSV)) & ! 842 / (DDcdSV - ( Sph_av *DScdSV & ! 843 +(1.-Sph_av)*DFcdSV)) & ! 844 , unun )! 845 DendOK = max(zero, & ! 846 sign(unun, Sph_av *DScdSV & ! Small Grains 847 +(1.-Sph_av)*DFcdSV & ! Faceted Grains 848 - Siz_av )) ! 849 ! +... REMARQUE: le type moyen (dendritique ou non) depend 850 ! + ^^^^^^^^ de la comparaison avec le diametre optique 851 ! + d'une neige recente de dendricite nulle 852 ! +... REMARK: the mean type (dendritic or not) depends 853 ! + ^^^^^^ on the comparaison with the optical diameter 854 ! + of a recent snow having zero dendricity 855 856 G1diff =( -DendOK *Den_av & 857 +(1.-DendOK)*Sph_av) *G1_dSV 858 G2diff = DendOK *Sph_av *G1_dSV & 859 +(1.-DendOK)*Siz_av 860 G1 = SameOK *G1same & 861 +(1.-SameOK)*G1diff 862 G2 = SameOK *G2same & 863 +(1.-SameOK)*G2diff 864 865 BG1sSV(ikl) = G1 & ! 866 * Bufs_N/max(epsi,Bufs_N) ! 867 BG2sSV(ikl) = G2 & ! 868 * Bufs_N/max(epsi,Bufs_N) ! 869 870 871 ! +--Update of Buffer Layer Content & Decision about creating a new snow layer 872 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 873 BufsSV(ikl) = Bufs_N ! [mm w.e.] 874 NLaysv(ikl) = min(unun, & ! 875 max(zero, & ! Allows to create 876 sign(unun,BufsSV(ikl) & ! a new snow Layer 877 -SMndSV )) & ! if Buffer > SMndSV 878 *max(zero, & ! Except if * Erosion 879 sign(unun,0.50 & ! dominates 880 -dsnbSV(ikl))) & ! 881 +max(zero, & ! Allows to create 882 sign(unun,BufsSV(ikl) & ! a new snow Layer 883 -SMndSV*3.00))) ! is Buffer > SMndSV*3 884 Bdzssv(ikl) = 1.e-3*BufsSV(ikl)*ro_Wat & ! [mm w.e.] -> [m w.e.] 885 /max(epsi,BrosSV(ikl))!& [m w.e.] -> [m] 886 887 390 888 END DO 391 889 392 890 393 891 394 395 396 IF (SnoMod) THEN 397 398 399 C +--Aeolian erosion and Blowing Snow 400 C +================================== 401 402 403 404 DO ikl=1,knonv 405 usthSV(ikl) = 1.0e+2 406 END DO 407 408 409 IF (BloMod) THEN 410 411 if (klonv.eq.1) then 412 if(isnoSV(1).ge.2 .and. 413 . TsisSV(1,max(1,isnoSV(1)))<273. .and. 414 . ro__SV(1,max(1,isnoSV(1)))<500. .and. 415 . eta_SV(1,max(1,isnoSV(1)))<epsi) then 416 C + ********** 417 call SISVAT_BSn 418 endif 419 else 420 call SISVAT_BSn 421 C + ********** 422 endif 423 424 425 426 427 428 429 430 ! Calculate threshold erosion velocity for next time step 431 ! Unlike in sisvat, computation is of threshold velocity made here (instead of sisvaesbl) 432 ! since we do not use sisvatesbl for the coupling with LMDZ 433 434 C +--Computation of threshold friction velocity for snow erosion 435 C --------------------------------------------------------------- 436 437 rCd10n = 1. / 26.5 ! Vt / u*t = 26.5 438 ! Budd et al. 1965, Antarct. Res. Series Fig.13 439 ! ratio developped during assumed neutral conditions 440 441 442 C +--Snow Properties 443 C + ~~~~~~~~~~~~~~~ 444 445 DO ikl = 1,knonv 446 447 isn = isnoSV(ikl) 448 449 450 451 DendOK = max(zero,sign(unun,epsi-G1snSV(ikl,isn) )) ! 452 SaltOK = min(1 , max(istdSV(2)-istoSV(ikl,isn),0)) ! 453 MeltOK = (unun ! 454 . -max(zero,sign(unun,TfSnow-epsi ! 455 . -TsisSV(ikl,isn) ))) ! Melting Snow 456 . * min(unun,DendOK ! 457 . +(1.-DendOK) ! 458 . *sign(unun, G2snSV(ikl,isn)-1.0)) ! 1.0 for 1mm 459 SnowOK = min(1 , max(isnoSV(ikl) +1 -isn ,0)) ! Snow Switch 460 461 G1snSV(ikl,isn) = SnowOK * G1snSV(ikl,isn) 462 . + (1.- SnowOK)*min(G1snSV(ikl,isn),G1_dSV) 463 G2snSV(ikl,isn) = SnowOK * G2snSV(ikl,isn) 464 . + (1.- SnowOK)*min(G2snSV(ikl,isn),G1_dSV) 465 466 SaltOK = min(unun, SaltOK + MeltOK) * SnowOK 467 468 469 C +--Mobility Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.) 470 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 471 SaltM1 = -0.750e-2 * G1snSV(ikl,isn) 472 . -0.500e-2 * G2snSV(ikl,isn)+ 0.500e00 !dendritic case 473 C + CAUTION: Guyomarc'h & Merindol Dendricity Sign is + 474 C + ^^^^^^^^ MAR Dendricity Sign is - 475 SaltM2 = -0.833d-2 * G1snSV(ikl,isn) 476 . -0.583d-2 * G2snSV(ikl,isn)+ 0.833d00 !non-dendritic case 477 478 c SaltMo = (DendOK * SaltM1 + (1.-DendOK) * SaltM2 ) 479 SaltMo = 0.625 !SaltMo pour d=s=0.5 480 481 !weighting SaltMo with surface snow density (Vionnet et al. 2012) 482 cc#AE FacRho = 1.25 - 0.0042 * ro__SV(ikl,isn) 483 cc#AE SaltMo = 0.34 * SaltMo + 0.66 * FacRho !needed for polar snow 484 MIN_Mo = 0. 485 c SaltMo = max(SaltMo,MIN_Mo) 486 c SaltMo = SaltOK * SaltMo + (1.-SaltOK) * min(SaltMo,SaltMx) 487 c #TUNE SaltMo = SaltOK * SaltMo - (1.-SaltOK) * 0.9500 488 SaltMo = max(SaltMo,epsi-unun) 489 490 C +--Influence of Density on Threshold Shear Stress 491 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 492 Por_BS = 1. - 300. / ro_Ice 493 ShearS = Por_BS / (1.-Por_BS) 494 C +... SheaBS = Arg(sqrt(shear = max shear stress in snow)): 495 C + shear = 3.420d00 * exp(-(Por_BS +Por_BS) 496 C + . /(unun -Por_BS)) 497 C + SheaBS : see de Montmollin (1978), 498 C + These Univ. Sci. Medic. Grenoble, Fig. 1 p. 124 499 500 C +--Snow Drift Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.) 501 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 502 ArguSi = -0.085 *us__SV(ikl)/rCd10n 503 !V=u*/sqrt(CD) eqs 2 to 4 Gallee et al. 2001 504 505 SaltSI(ikl,isn) = -2.868 * exp(ArguSi) + 1 + SaltMo 506 507 508 C +--Threshold Friction Velocity 509 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 510 if(ro__SV(ikl,isn)>300.) then 511 Por_BS = 1.000 - ro__SV(ikl,isn) /ro_Ice 512 else 513 Por_BS = 1.000 - 300. /ro_Ice 514 endif 515 516 ShearX = Por_BS/max(epsi,1.-Por_BS) 517 Fac_Mo = exp(-ShearX+ShearS) 518 C + Gallee et al., 2001 eq 5, p5 519 520 if (usth_param .eq. "gal") then 521 Salt_us = (log(2.868) - log(1 + SaltMo)) * rCd10n/0.085 522 Salt_us = Salt_us * Fac_Mo 523 C +... Salt_us : Extension of Guyomarc'h & Merindol 1998 with 524 C +... de Montmollin (1978). Gallee et al. 2001 525 endif 526 527 if (usth_param .eq. "lis") then !Liston et al. 2007 528 if(ro__SV(ikl,isn)>300.) then 529 Salt_us = 0.005*exp(0.013*ro__SV(ikl,isn)) 530 else 531 Salt_us = 0.01*exp(0.003*ro__SV(ikl,isn)) 532 endif 533 endif 534 535 SnowOK = 1 -min(1,iabs(isn-isnoSV(ikl))) !Switch new vs old snow 536 537 usthSV(ikl) = SnowOK * (Salt_us) 538 . + (1.-SnowOK)* usthSV(ikl) 539 540 END DO 541 542 543 544 ! Feeback between blowing snow turbulent Scale u* (commented here 545 ! since ustar is an input variable (not in/out) of inlandsis) 546 ! ----------------------------------------------------------------- 547 548 549 ! VVa_OK = max(0.000001, VVaSBL(ikl)) 550 ! sss__N = vonkar * VVa_OK 551 ! sss__F = (sqrCm0(ikl) - psim_z + psim_0) 552 ! usuth0 = sss__N /sss__F ! u* if NO Blow. Snow 553 554 ! sss__G = 0.27417 * gravit 555 556 ! ! ______________ _____ 557 ! ! Newton-Raphson (! Iteration, BEGIN) 558 ! ! ~~~~~~~~~~~~~~ ~~~~~ 559 ! DO iit=1,nit 560 ! sss__K = gravit * r_Turb * A_Turb *za__SV(ikl) 561 ! . *rCDmSV(ikl)*rCDmSV(ikl) 562 ! . /(1.+0.608*QaT_SV(ikl)-qsnoSV(ikl)) 563 ! us_127 = exp( SblPom *log(us__SV(ikl))) 564 ! us_227 = us_127 * us__SV(ikl) 565 ! us_327 = us_227 * us__SV(ikl) 566 ! us_427 = us_327 * us__SV(ikl) 567 ! us_527 = us_427 * us__SV(ikl) 568 569 ! us__SV(ikl) = us__SV(ikl) 570 ! . - ( us_527 *sss__F /sss__N 571 ! . - us_427 572 ! . - us_227 *qsnoSV(ikl)*sss__K 573 ! . + (us__SV(ikl)*us__SV(ikl)-usthSV(ikl)*usthSV(ikl))/sss__G) 574 ! . /( us_427*5.27*sss__F /sss__N 575 ! . - us_327*4.27 576 ! . - us_127*2.27*qsnoSV(ikl)*sss__K 577 ! . + us__SV(ikl)*2.0 /sss__G) 578 579 ! us__SV(ikl)= min(us__SV(ikl),usuth0) 580 ! us__SV(ikl)= max(us__SV(ikl),epsi ) 581 ! rCDmSV(ikl)= us__SV(ikl)/VVa_OK 582 ! ! #AE sss__F = vonkar /rCDmSV(ikl) 583 ! ENDDO 584 585 ! ! ______________ ___ 586 ! ! Newton-Raphson (! Iteration, END ) 587 ! ! ~~~~~~~~~~~~~~ ~~~ 588 589 ! us_127 = exp( SblPom *log(us__SV(ikl))) 590 ! us_227 = us_127 * us__SV(ikl) 591 592 ! ! Momentum Turbulent Scale u*: 0-Limit in case of no Blow. Snow 593 ! ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 594 ! dusuth = us__SV(ikl) - usthSV(ikl) ! u* - uth* 595 ! signus = max(sign(unun,dusuth),zero) ! 1 <=> u* - uth* > 0 596 ! us__SV(ikl) = ! 597 ! . us__SV(ikl) *signus + ! u* (_BS) 598 ! . usuth0 ! u* (nBS) 599 ! . *(1.-signus) ! 600 601 602 603 604 ! Blowing Snow Turbulent Scale ss* 605 ! --------------------------------------- 606 607 hSalSV(ikl) = 8.436e-2 * us__SV(ikl)**SblPom 608 609 if (qsalt_param .eq. "pom") then 610 qSalSV(ikl) = (us__SV(ikl)**2 - usthSV(ikl)**2) *signus 611 . / (hSalSV(ikl) * gravit * us__SV(ikl) * 3.25) 612 endif 613 614 if (qsalt_param .eq. "bin") then 615 qSalSV(ikl) = (us__SV(ikl) * us__SV(ikl) 616 . -usthSV(ikl) * usthSV(ikl))*signus 617 . * 0.535 / (hSalSV(ikl) * gravit) 618 endif 619 620 qSalSV(ikl) = qSalSV(ikl)/rht_SV(ikl) ! conversion kg/m3 to kg/kg 621 622 ssstar = rCDmSV(ikl) * (qsnoSV(ikl) - qSalSV(ikl)) 623 . * r_Turb !Bintanja 2000, BLM 624 !r_Turb compensates for an overestim. of the blown snow part. fall velocity 625 626 uss_SV(ikl) = min(zero , us__SV(ikl) *ssstar) 627 uss_SV(ikl) = max(-0.0001 , uss_SV(ikl)) 628 629 630 631 632 ENDIF ! BloMod 633 634 C + ------------------------------------------------------ 635 C +--Buffer Layer 636 C + ----------------------------------------------------- 637 638 DO ikl=1,knonv 639 c BufsSV(ikl) [mm w.e.] i.e, i.e., [kg/m2] 640 d_Bufs = max(dsn_SV(ikl) *dt__SV,0.) ! 641 dsn_SV(ikl) = 0. ! 642 Bufs_N = BufsSV(ikl) +d_Bufs ! 643 644 645 C +--Snow Density 646 C + ^^^^^^^^^^^^ 647 Polair = zero 648 c #NP Polair = max(zero, ! 649 c #NP. sign(unun,TaPole ! 650 c #NP. -TaT_SV(ikl))) ! 651 Polair = max(zero, ! 652 . sign(unun,TaPole ! 653 . -TaT_SV(ikl))) ! 654 Buf_ro = max( rosMin, ! Fallen Snow Density 655 . roSn_1+roSn_2* (TaT_SV(ikl)-TfSnow) ! [kg/m3] 656 . +roSn_3*sqrt( VV__SV(ikl))) ! Pahaut (CEN), Etienne: use wind speed at first model level instead of 10m wind 657 c #NP BufPro = max( rosMin, ! Fallen Snow Density 658 c #NP. 104. *sqrt( max( VV10SV(ikl)-6.0,0.0))) ! Kotlyakov (1961) 659 660 ! C.Agosta option for snow density, same as for BS i.e. 661 ! is_ok_density_kotlyakov=.false. 662 c #BS density_kotlyakov = .false. !C.Amory BS 2018 663 C + ... Fallen Snow Density, Adapted for Antarctica 664 if (is_ok_density_kotlyakov) then 665 tt_tmp = TaT_SV(ikl)-TfSnow 666 !vv_tmp = VV10SV(ikl) 667 vv_tmp=VV__SV(ikl) ! Etienne: use wind speed at first model level instead of 10m wind 668 C + ... [ A compromise between 669 C + ... Kotlyakov (1961) and Lenaerts (2012, JGR, Part1) ] 670 if (tt_tmp.ge.-10) then 671 BufPro = max( rosMin, 672 . 104. *sqrt( max( vv_tmp-6.0,0.0))) ! Kotlyakov (1961) 673 else 674 vv_virt = (tt_c*vv_tmp+vv_c*(tt_tmp+10)) 675 . /(tt_c+tt_tmp+10) 676 BufPro = 104. *sqrt( max( vv_virt-6.0,0.0)) 677 endif 678 else 679 C + ... [ density derived from observations of the first 50cm of 680 C + ... snow - cf. Rajashree Datta - and multiplied by 0.8 ] 681 C + ... C. Agosta, 2016-09 682 cc #SD BufPro = 149.2 + 6.84*VV10SV(ikl) + 0.48*Tsrfsv(ikl) 683 cc #SD BufPro = 125 + 14*VV10SV(ikl) + 0.6*Tsrfsv(ikl) !MAJ CK and CAm 684 ! BufPro = 200 + 21 * VV10SV(ikl)!CK 29/07/19 685 BufPro = 200 + 21 * VV__SV(ikl)!Etienne: use wind speed at first model level instead of 10m wind 686 endif 687 688 Bros_N = (1. - Polair) * Buf_ro ! Temperate Snow 689 . + Polair * BufPro ! Polar Snow 690 691 Bros_N = max( 20.,max(rosMin, Bros_N)) 692 Bros_N = min(400.,min(rosMax-1,Bros_N)) ! for dz_min in SISVAT_zSn 693 694 695 ! Density of deposited blown snow 696 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 697 698 if (BloMod) then 699 Bros_N = frsno 700 ro_new = ro__SV(ikl,max(1,isnoSV(ikl))) 701 ro_new = max(Bros_N,min(roBdSV,ro_new)) 702 Fac = 1-((ro__SV(ikl,max(1,isnoSV(ikl))) 703 . -roBdSV)/(500.-roBdSV)) 704 Fac = max(0.,min(1.,Fac)) 705 dsnbSV(ikl) = Fac*dsnbSV(ikl) 706 Bros_N = Bros_N * (1.0-dsnbSV(ikl)) 707 . + ro_new * dsnbSV(ikl) 708 endif 709 710 711 ! Time averaged Density of deposited blown Snow 712 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 713 714 BrosSV(ikl) =(Bros_N * d_Bufs ! 715 . +BrosSV(ikl)* BufsSV(ikl))! 716 . / max(epsi,Bufs_N) ! 717 718 719 C +-- S.Falling Snow Properties (computed as in SISVAT_zAg) 720 C + ^^^^^^^^^^^^^^^^^^^^^^^ 721 Buf_G1 = max(-G1_dSV, ! Temperate Snow 722 . min(Dendr1*VV__SV(ikl)-Dendr2, ! Dendricity 723 . Dendr3 )) ! 724 Buf_G2 = min( Spher4, ! Temperate Snow 725 . max(Spher1*VV__SV(ikl)+Spher2, ! Sphericity 726 . Spher3 )) ! 727 ! EV: now control buf_sph_pol and bug_siz_pol in physiq.def 728 Buf_G1 = (1. - Polair) * Buf_G1 ! Temperate Snow 729 . + Polair * buf_sph_pol ! Polar Snow 730 Buf_G2 = (1. - Polair) * Buf_G2 ! Temperate Snow 731 . + Polair * buf_siz_pol ! Polar Snow 732 G1 = Buf_G1 ! NO Blown Snow 733 G2 = Buf_G2 ! NO Blown Snow 734 735 736 737 IF (BloMod) THEN 738 739 ! S.1. Meme Type de Neige / same Grain Type 740 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 741 742 SameOK = max(zero, 743 . sign(unun, Buf_G1 *G1_dSV 744 . - eps_21 )) 745 G1same = ((1.0-dsnbSV(ikl))*Buf_G1+dsnbSV(ikl) *G1_dSV) 746 G2same = ((1.0-dsnbSV(ikl))*Buf_G2+dsnbSV(ikl) *ADSdSV) 747 ! Blowing Snow Properties: G1_dSV, ADSdSV 748 749 ! S.2. Types differents / differents Types 750 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 751 typ__1 = max(zero,sign(unun,epsi-Buf_G1)) ! =1.=> Dendritic 752 zroNEW = typ__1 *(1.0-dsnbSV(ikl)) ! fract.Dendr.Lay. 753 . + (1.-typ__1) * dsnbSV(ikl) ! 754 G1_NEW = typ__1 *Buf_G1 ! G1 of Dendr.Lay. 755 . + (1.-typ__1) *G1_dSV ! 756 G2_NEW = typ__1 *Buf_G2 ! G2 of Dendr.Lay. 757 . + (1.-typ__1) *ADSdSV ! 758 zroOLD = (1.-typ__1) *(1.0-dsnbSV(ikl)) ! fract.Spher.Lay. 759 . + typ__1 * dsnbSV(ikl) ! 760 G1_OLD = (1.-typ__1) *Buf_G1 ! G1 of Spher.Lay. 761 . + typ__1 *G1_dSV ! 762 G2_OLD = (1.-typ__1) *Buf_G2 ! G2 of Spher.Lay. 763 . + typ__1 *ADSdSV ! 764 SizNEW = -G1_NEW *DDcdSV/G1_dSV ! Size Dendr.Lay. 765 . +(1.+G1_NEW /G1_dSV) ! 766 . *(G2_NEW *DScdSV/G1_dSV ! 767 . +(1.-G2_NEW /G1_dSV)*DFcdSV) ! 768 SphNEW = G2_NEW /G1_dSV ! Spher.Dendr.Lay. 769 SizOLD = G2_OLD ! Size Spher.Lay. 770 SphOLD = G1_OLD /G1_dSV ! Spher.Spher.Lay. 771 Siz_av = (zroNEW*SizNEW+zroOLD*SizOLD) ! Averaged Size 772 Sph_av = min( zroNEW*SphNEW+zroOLD*SphOLD ! 773 . , unun) ! Averaged Sphericity 774 Den_av = min((Siz_av -( Sph_av *DScdSV ! 775 . +(1.-Sph_av)*DFcdSV)) ! 776 . / (DDcdSV -( Sph_av *DScdSV ! 777 . +(1.-Sph_av)*DFcdSV)) ! 778 . , unun) ! 779 DendOK = max(zero, ! 780 . sign(unun, Sph_av *DScdSV ! Small Grains 781 . +(1.-Sph_av)*DFcdSV ! Faceted Grains 782 . - Siz_av )) ! 783 C +... REMARQUE: le type moyen (dendritique ou non) depend 784 C + ^^^^^^^^ de la comparaison avec le diametre optique 785 C + d'une neige recente de dendricite nulle 786 C +... REMARK: the mean type (dendritic or not) depends 787 C + ^^^^^^ on the comparaison with the optical diameter 788 C + of a recent snow having zero dendricity 789 790 G1diff =( -DendOK *Den_av 791 . +(1.-DendOK)*Sph_av) *G1_dSV 792 G2diff = DendOK *Sph_av *G1_dSV 793 . +(1.-DendOK)*Siz_av 794 G1 = SameOK *G1same 795 . +(1.-SameOK)*G1diff 796 G2 = SameOK *G2same 797 . +(1.-SameOK)*G2diff 798 ENDIF 799 800 801 802 ! S.1. Meme Type de Neige / same Grain Type 803 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 804 SameOK = max(zero, 805 . sign(unun, Buf_G1 *BG1sSV(ikl) 806 . - eps_21 )) 807 G1same = (d_Bufs*Buf_G1+BufsSV(ikl)*BG1sSV(ikl)) 808 . /max(epsi,Bufs_N) 809 G2same = (d_Bufs*Buf_G2+BufsSV(ikl)*BG2sSV(ikl)) 810 . /max(epsi,Bufs_N) 811 812 ! S.2. Types differents / differents Types 813 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 814 815 typ__1 = max(zero,sign(unun,epsi-Buf_G1)) ! =1.=> Dendritic 816 zroNEW =( typ__1 *d_Bufs ! fract.Dendr.Lay. 817 . + (1.-typ__1) *BufsSV(ikl)) ! 818 . /max(epsi,Bufs_N) ! 819 G1_NEW = typ__1 *Buf_G1 ! G1 of Dendr.Lay. 820 . + (1.-typ__1) *BG1sSV(ikl) ! 821 G2_NEW = typ__1 *Buf_G2 ! G2 of Dendr.Lay. 822 . + (1.-typ__1) *BG2sSV(ikl) ! 823 zroOLD =((1.-typ__1) *d_Bufs ! fract.Spher.Lay. 824 . + typ__1 *BufsSV(ikl)) ! 825 . /max(epsi,Bufs_N) ! 826 G1_OLD = (1.-typ__1) *Buf_G1 ! G1 of Spher.Lay. 827 . + typ__1 *BG1sSV(ikl) ! 828 G2_OLD = (1.-typ__1) *Buf_G2 ! G2 of Spher.Lay. 829 . + typ__1 *BG2sSV(ikl) ! 830 SizNEW = -G1_NEW *DDcdSV/G1_dSV ! Size Dendr.Lay. 831 . +(1.+G1_NEW /G1_dSV) ! 832 . *(G2_NEW *DScdSV/G1_dSV ! 833 . +(1.-G2_NEW /G1_dSV)*DFcdSV) ! 834 SphNEW = G2_NEW /G1_dSV ! Spher.Dendr.Lay. 835 SizOLD = G2_OLD ! Size Spher.Lay. 836 SphOLD = G1_OLD /G1_dSV ! Spher.Spher.Lay. 837 Siz_av = ( zroNEW *SizNEW+zroOLD*SizOLD) ! Averaged Size 838 Sph_av = min( zroNEW *SphNEW+zroOLD*SphOLD ! 839 . , unun ) ! Averaged Sphericity 840 Den_av = min((Siz_av - ( Sph_av *DScdSV ! 841 . +(1.-Sph_av)*DFcdSV)) ! 842 . / (DDcdSV - ( Sph_av *DScdSV ! 843 . +(1.-Sph_av)*DFcdSV)) ! 844 . , unun )! 845 DendOK = max(zero, ! 846 . sign(unun, Sph_av *DScdSV ! Small Grains 847 . +(1.-Sph_av)*DFcdSV ! Faceted Grains 848 . - Siz_av )) ! 849 C +... REMARQUE: le type moyen (dendritique ou non) depend 850 C + ^^^^^^^^ de la comparaison avec le diametre optique 851 C + d'une neige recente de dendricite nulle 852 C +... REMARK: the mean type (dendritic or not) depends 853 C + ^^^^^^ on the comparaison with the optical diameter 854 C + of a recent snow having zero dendricity 855 856 G1diff =( -DendOK *Den_av 857 . +(1.-DendOK)*Sph_av) *G1_dSV 858 G2diff = DendOK *Sph_av *G1_dSV 859 . +(1.-DendOK)*Siz_av 860 G1 = SameOK *G1same 861 . +(1.-SameOK)*G1diff 862 G2 = SameOK *G2same 863 . +(1.-SameOK)*G2diff 864 865 BG1sSV(ikl) = G1 ! 866 . * Bufs_N/max(epsi,Bufs_N) ! 867 BG2sSV(ikl) = G2 ! 868 . * Bufs_N/max(epsi,Bufs_N) ! 869 870 871 C +--Update of Buffer Layer Content & Decision about creating a new snow layer 872 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 873 BufsSV(ikl) = Bufs_N ! [mm w.e.] 874 NLaysv(ikl) = min(unun, ! 875 . max(zero, ! Allows to create 876 . sign(unun,BufsSV(ikl) ! a new snow Layer 877 . -SMndSV )) ! if Buffer > SMndSV 878 . *max(zero, ! Except if * Erosion 879 . sign(unun,0.50 ! dominates 880 . -dsnbSV(ikl))) ! 881 . +max(zero, ! Allows to create 882 . sign(unun,BufsSV(ikl) ! a new snow Layer 883 . -SMndSV*3.00))) ! is Buffer > SMndSV*3 884 Bdzssv(ikl) = 1.e-3*BufsSV(ikl)*ro_Wat ! [mm w.e.] -> [m w.e.] 885 . /max(epsi,BrosSV(ikl))!& [m w.e.] -> [m] 886 887 888 END DO 889 890 891 892 ! Snow Pack Discretization(option XF in MAR) 893 ! ========================================== 894 895 896 if (discret_xf.AND.klonv.eq.1) then 897 898 if(isnoSV(1).ge.1.or.NLaysv(1).ge.1) then 899 C + ********** 900 call SISVAT_zSn 901 C + ********** 902 endif 892 ! Snow Pack Discretization(option XF in MAR) 893 ! ========================================== 894 895 896 if (discret_xf.AND.klonv.eq.1) then 897 898 if(isnoSV(1).ge.1.or.NLaysv(1).ge.1) then 899 ! + ********** 900 call SISVAT_zSn 901 ! + ********** 902 endif 903 else 904 ! + ********** 905 call SISVAT_zSn 906 ! + ********** 907 endif 908 909 ! + ********** 910 ! #ve call SISVAT_wEq('_zSn ',0) 911 ! + ********** 912 913 ! Add a new Snow Layer 914 ! ==================== 915 916 DO ikl=1,knonv 917 918 isnoSV(ikl) = isnoSV(ikl) +NLaysv(ikl) 919 isn = isnoSV(ikl) 920 dzsnSV(ikl,isn) = dzsnSV(ikl,isn) * (1-NLaysv(ikl)) & 921 + Bdzssv(ikl) * NLaysv(ikl) 922 TsisSV(ikl,isn) = TsisSV(ikl,isn) * (1-NLaysv(ikl)) & 923 + min(TaT_SV(ikl),Tf_Sno) *NLaysv(ikl) 924 ro__SV(ikl,isn) = ro__SV(ikl,isn) * (1-NLaysv(ikl)) & 925 + Brossv(ikl) * NLaysv(ikl) 926 eta_SV(ikl,isn) = eta_SV(ikl,isn) * (1-NLaysv(ikl)) ! + 0. 927 agsnSV(ikl,isn) = agsnSV(ikl,isn) * (1-NLaysv(ikl)) ! + 0. 928 G1snSV(ikl,isn) = G1snSV(ikl,isn) * (1-NLaysv(ikl)) & 929 + BG1ssv(ikl) * NLaysv(ikl) 930 G2snSV(ikl,isn) = G2snSV(ikl,isn) * (1-NLaysv(ikl)) & 931 + BG2ssv(ikl) * NLaysv(ikl) 932 istoSV(ikl,isn) = istoSV(ikl,isn) * (1-NLaysv(ikl)) & 933 + max(zer0,sign(un_1,TaT_SV(ikl) & 934 -Tf_Sno-eps_21)) * istdSV(2) & 935 * NLaysv(ikl) 936 BufsSV(ikl) = BufsSV(ikl) * (1-NLaysv(ikl)) 937 NLaysv(ikl) = 0 938 939 940 END DO 941 942 943 ! Snow Pack Thickness 944 ! ------------------- 945 946 DO ikl=1,knonv 947 z_snsv(ikl) = 0.0 948 END DO 949 DO isn=1,nsno 950 DO ikl=1,knonv 951 z_snsv(ikl) = z_snsv(ikl) + dzsnSV(ikl,isn) 952 zzsnsv(ikl,isn) = z_snsv(ikl) 953 END DO 954 END DO 955 956 957 958 END IF ! SnoMod 959 960 961 962 ! Soil Albedo: Soil Humidity Correction 963 ! ========================================== 964 965 ! REFERENCE: McCumber and Pielke (1981), Pielke (1984) 966 ! ^^^^^^^^^ 967 DO ikl=1,knonv 968 albssv(ikl) = & 969 alb0SV(ikl) *(1.0-min(half,eta_SV( ikl,0) & 970 /etadSV(isotSV(ikl)))) 971 ! REMARK: Albedo of Water Surfaces (isotSV=0): 972 ! ^^^^^^ alb0SV := 2 X effective value, while 973 ! eta_SV := etadSV 974 END DO 975 976 977 ! Snow Pack Optical Properties 978 ! ============================ 979 980 IF (SnoMod) THEN 981 982 ! ****** 983 call SnOptP(jjtime) 984 ! ****** 985 986 ELSE 987 DO ikl=1,knonv 988 sEX_sv(ikl,1) = 1.0 989 sEX_sv(ikl,0) = 0.0 990 albisv(ikl) = albssv(ikl) 991 END DO 992 END IF 993 994 995 996 ! Soil optical properties 997 ! ============================= 998 !Etienne: as in inlandis we do not call vgopt, we need to define 999 !the albedo alb_SV and to calculate the 1000 !absorbed Solar Radiation by Surfac (Normaliz)[-] SoSosv 1001 1002 1003 DO ikl=1,klonv 1004 1005 e_pRad = 2.5 * coszSV(ikl) ! exponential argument, 1006 ! ! V/nIR radiation partitioning, 1007 ! ! DR97, 2, eqn (2.53) & (2.54) 1008 e1pRad = 1.-exp(-e_pRad) ! exponential, V/nIR Rad. Part. 1009 exdRad= 1. 1010 1011 ! Visible Part of the Solar Radiation Spectrum (V, 0.4--0.7mi.m) 1012 A_Rad0 = 0.25 + 0.697 * e1pRad ! Absorbed Vis. Radiation 1013 absg_V = (1.-albisv(ikl))*(A_Rad0*exdRad) ! 1014 1015 ! Near-IR Part of the Solar Radiation Spectrum (nIR, 0.7--2.8mi.m) 1016 1017 A_Rad0 = 0.80 + 0.185 * e1pRad ! Absorbed nIR. Radiation 1018 absgnI = (1.-albisv(ikl))*(A_Rad0*exdRad) ! 1019 1020 SoSosv(ikl) = (absg_V+absgnI)*0.5d0 1021 1022 alb_SV(ikl) = albisv(ikl) 1023 1024 END DO 1025 1026 ! ********** 1027 ! #ve call SISVAT_wEq('SnOptP',0) 1028 ! ********** 1029 1030 1031 ! Surface Emissivity (Etienne: simplified calculation for landice) 1032 ! ============================================================= 1033 ! 1034 DO ikl=1,knonv 1035 LSnMsk = min( 1,isnoSV(ikl)) 1036 Eso_sv(ikl)= EmiSol*(1-LSnMsk)+EmiSno*LSnMsk ! Sol+Sno Emissivity 1037 emi_SV(ikl)= EmiSol*(1-LSnMsk) + EmiSno*LSnMsk 1038 END DO 1039 1040 1041 1042 1043 ! Upward IR (INPUT, from previous time step) 1044 ! =================================================================== 1045 1046 DO ikl=1,knonv 1047 ! #e1 Enrsvd(ikl) = - IRs_SV(ikl) 1048 IRupsv(ikl) = IRs_SV(ikl) 1049 END DO 1050 1051 1052 ! Turbulence 1053 ! ========== 1054 1055 ! Latent Heat of Vaporization/Sublimation 1056 ! --------------------------------------- 1057 1058 DO ikl=1,knonv 1059 SnoWat = min(isnoSV(ikl),0) 1060 Lx_H2O(ikl) = & 1061 (1.-SnoWat) * LhvH2O & 1062 + SnoWat *(LhsH2O * (1.-eta_SV(ikl,isnoSV(ikl))) & 1063 +LhvH2O * eta_SV(ikl,isnoSV(ikl)) ) 1064 END DO 1065 1066 1067 1068 1069 ! Aerodynamic Resistance (calculated from drags given by LMDZ) 1070 ! Commented because already calculated in surf_inlandsis_mod 1071 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1072 ! DO ikl=1,knonv 1073 ! ram_sv(ikl) = 1./(cdM_SV(ikl)*max(VV__SV(ikl),eps6)) 1074 ! rah_sv(ikl) = 1./(cdH_SV(ikl)*max(VV__SV(ikl),eps6)) 1075 ! END DO 1076 1077 1078 1079 ! Soil Energy Balance 1080 ! ===================== 1081 1082 1083 if (iflag_temp_inlandsis .eq. 0) then 1084 1085 call SISVAT_TSo 1086 1087 else 1088 DO ikl=1,knonv 1089 Tsf_SV(ikl)=Tsrfsv(ikl) 1090 END DO 1091 1092 call SISVAT_TS2 1093 1094 end if 1095 1096 1097 ! ********** 1098 ! #ve call SISVAT_wEq('_TSo ',0) 1099 ! ********** 1100 1101 1102 1103 ! Soil Water Potential 1104 ! ------------------------ 1105 1106 DO isl=-nsol,0 1107 DO ikl=1,knonv 1108 ist = isotSV(ikl) ! Soil Type 1109 psi_sv(ikl,isl) = psidSV(ist) & ! DR97, Eqn.(3.34) 1110 *(etadSV(ist) /max(eps6,eta_SV(ikl,isl))) & ! 1111 **bCHdSV(ist) ! 1112 1113 1114 ! Soil Hydraulic Conductivity 1115 ! --------------------------- 1116 1117 Khydsv(ikl,isl) = s2__SV(ist) & ! DR97, Eqn.(3.35) 1118 *(eta_SV(ikl,isl)**(2.*bCHdSV(ist)+3.)) ! 1119 END DO 1120 END DO 1121 1122 1123 ! Melting / Refreezing in the Snow Pack 1124 ! ===================================== 1125 1126 IF (SnoMod) THEN 1127 1128 ! ********** 1129 call SISVAT_qSn 1130 ! ********** 1131 1132 ! ********** 1133 ! #ve call SISVAT_wEq('_qSn ',0) 1134 ! ********** 1135 1136 1137 ! Snow Pack Thickness 1138 ! ------------------- 1139 1140 DO ikl=1,knonv 1141 z_snsv(ikl) = 0.0 1142 END DO 1143 DO isn=1,nsno 1144 DO ikl=1,knonv 1145 z_snsv(ikl) = z_snsv(ikl) + dzsnSV(ikl,isn) 1146 zzsnsv(ikl,isn) = z_snsv(ikl) 1147 END DO 1148 END DO 1149 1150 1151 ! Energy in Excess is added to the first Soil Layer 1152 ! ------------------------------------------------- 1153 DO ikl=1,knonv 1154 z_snsv(ikl) = max(zer0, & 1155 sign(un_1,eps6-z_snsv(ikl))) 1156 TsisSV(ikl,0) = TsisSV(ikl,0) + EExcsv(ikl) & 1157 /(rocsSV(isotSV(ikl)) & 1158 +rcwdSV*eta_SV(ikl,0)) 1159 EExcsv(ikl) = 0. 1160 END DO 1161 1162 1163 END IF 1164 1165 1166 ! Soil Water Balance 1167 ! ===================== 1168 1169 ! ********** 1170 call SISVAT_qSo 1171 ! #m0. (Wats_0,Wats_1,Wats_d) 1172 ! ********** 1173 1174 1175 ! Surface Fluxes 1176 ! ===================== 1177 1178 DO ikl=1,knonv 1179 IRdwsv(ikl)=IRd_SV(ikl)*Eso_sv(ikl) ! Downward IR 1180 ! IRdwsv(ikl)=tau_sv(ikl) *IRd_SV(ikl)*Eso_sv(ikl) ! Downward IR 1181 ! . +(1.0-tau_sv(ikl))*IRd_SV(ikl)*Evg_sv(ikl) ! ! Etienne, remove vegetation component 1182 IRupsv(ikl) = IRupsv(ikl) ! Upward IR 1183 IRu_SV(ikl) = -IRupsv(ikl) & ! Upward IR 1184 +IRd_SV(ikl) & ! (effective) 1185 -IRdwsv(ikl) ! (positive) 1186 1187 TBr_sv(ikl) =sqrt(sqrt(IRu_SV(ikl)/StefBo)) ! Brightness 1188 ! ! Temperature 1189 uts_SV(ikl) = (HSv_sv(ikl) +HSs_sv(ikl)) & ! u*T* 1190 /(rhT_SV(ikl) *cp) ! 1191 uqs_SV(ikl) = (HLv_sv(ikl) +HLs_sv(ikl)) & ! u*q* 1192 /(rhT_SV(ikl) *LhvH2O) ! 1193 LMO_SV(ikl) = TaT_SV(ikl)*(us__SV(ikl)**3) & 1194 /gravit/uts_SV(ikl)/vonKrm ! MO length 1195 1196 1197 ! Surface Temperature 1198 ! ^^^^^^^^^^^^^^^^^^^^ 1199 1200 IF (iflag_tsurf_inlandsis .EQ. 0) THEN 1201 1202 Tsrfsv(ikl) =TsisSV(ikl,isnoSV(ikl)) 1203 1204 ELSE IF (iflag_tsurf_inlandsis .GT. 0) THEN 1205 ! Etienne: extrapolation from the two uppermost levels: 1206 1207 if (isnoSV(ikl) >=2) then 1208 zm1=-dzsnSV(ikl,isnoSV(ikl))/2. 1209 zm2=-(dzsnSV(ikl,isnoSV(ikl)) + dzsnSV(ikl,isnoSV(ikl)-1)/2.) 1210 else if (isnoSV(ikl) .EQ. 1) then 1211 zm1=-dzsnSV(ikl,isnoSV(ikl))/2. 1212 zm2=-(dzsnSV(ikl,isnoSV(ikl))+dz_dSV(0)/2.) 1213 else 1214 zm1=-dz_dSV(0)/2. 1215 zm2=-(dz_dSV(0)+dz_dSV(-1)/2.) 1216 1217 end if 1218 1219 coefslope=(TsisSV(ikl,isnoSV(ikl))-TsisSV(ikl,isnoSV(ikl)-1)) & 1220 /(zm1-zm2) 1221 Tsrfsv(ikl)=TsisSV(ikl,isnoSV(ikl))+coefslope*(0. - zm1) 1222 1223 1224 ELSE !(default) 1225 1226 Tsrfsv(ikl) =TsisSV(ikl,isnoSV(ikl)) 1227 1228 END IF 1229 1230 1231 END DO 1232 1233 ! Snow Pack Properties (sphericity, dendricity, size) 1234 ! =================================================== 1235 1236 IF (SnoMod) THEN 1237 1238 if (discret_xf .AND. klonv.eq.1) then 1239 if(isnoSV(1).ge.1) then 1240 ! + ********** 1241 call SISVAT_GSn 1242 ! + ********** 1243 endif 1244 else 1245 ! + ********** 1246 call SISVAT_GSn 1247 ! + ********** 1248 endif 1249 1250 1251 END IF 1252 1253 1254 ! Roughness Length for next time step 1255 !==================================== 1256 1257 ! Note that in INLANDSIS, we treat only ice covered surfaces so calculation 1258 ! of z0 is much simpler (no subgrid fraction of ocean or land) 1259 ! old calculations are commented below 1260 1261 1262 ! +--Roughness Length for Momentum 1263 ! + ----------------------------- 1264 1265 ! ETIENNE WARNING: changes have been made wrt original SISVAT 1266 1267 ! +--Land+Sea-Ice / Ice-free Sea Mask 1268 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1269 DO ikl=1,knonv 1270 IcIndx(ikl) = 0 1271 ENDDO 1272 DO isn=1,nsno 1273 DO ikl=1,knonv 1274 1275 IcIndx(ikl) = max(IcIndx(ikl), & 1276 isn*max(0, & 1277 sign(1, & 1278 int(ro__SV(ikl,isn)-900.)))) 1279 ENDDO 1280 ENDDO 1281 1282 DO ikl=1,knonv 1283 LISmsk = 1. ! in inlandsis, land only 1284 IceMsk = max(0,sign(1 ,IcIndx(ikl)-1) ) 1285 SnoMsk = max(min(isnoSV(ikl)-iiceSV(ikl),1),0) 1286 1287 1288 ! +--Z0 Smooth Regime over Snow (Andreas 1995, CRREL Report 95-16, p. 8) 1289 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1290 Z0m_nu = 5.e-5 ! z0s~(10-d)*exp(-vonkar/sqrt(1.1e-03)) 1291 1292 ! +--Z0 Saltat.Regime over Snow (Gallee et al., 2001, BLM 99 (19) p.11) 1293 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1294 1295 u2star = us__SV(ikl) *us__SV(ikl) 1296 Z0mBSn = u2star *0.536e-3 - 61.8e-6 1297 Z0mBSn = max(Z0mBS0 ,Z0mBSn) 1298 1299 ! +--Z0 Smooth + Saltat. Regime 1300 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1301 Z0enSV(ikl) = Z0m_nu & 1302 + Z0mBSn 1303 1304 1305 ! Calculation of snow roughness length 1306 !===================================== 1307 IF (iflag_z0m_snow .EQ. 0) THEN 1308 1309 Z0m_Sn=prescribed_z0m_snow 1310 1311 ELSE IF (iflag_z0m_snow .EQ. 1) THEN 1312 1313 Z0m_Sn=Z0enSV(ikl) 1314 1315 ELSE IF (iflag_z0m_snow .EQ. 2) THEN 1316 1317 ! +--Rough Snow Surface Roughness Length (Variable Sastrugi Height) 1318 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1319 A_Fact = 1.0000 ! Andreas et al., 2004, p.4 1320 ! ! ams.confex.com/ams/pdfpapers/68601.pdf 1321 1322 ! Parameterization of z0 dependance on Temperature (C. Amory, 2017) 1323 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1324 ! Z0=f(T) deduced from observations, Adelie Land, dec2012-dec2013 1325 1326 1327 coefa = 0.1658 !0.1862 !Ant 1328 coefb = -50.3869 !-55.7718 !Ant 1329 ta1 = 253.15 !255. Ant 1330 ta2 = 273.15 1331 ta3 = 273.15+3 1332 z01 = exp(coefa*ta1 + coefb) !~0.2 ! ~0.25 mm 1333 z02 = exp(coefa*ta2 + coefb) !~6 !~7 mm 1334 z03 = z01 1335 coefc = log(z03/z02)/(ta3-ta2) 1336 coefd = log(z03)-coefc*ta3 1337 1338 if (TaT_SV(ikl) .lt. ta1) then 1339 Z0_obs = z01 1340 else if (TaT_SV(ikl).ge.ta1 .and. TaT_SV(ikl).lt.ta2) then 1341 Z0_obs = exp(coefa*TaT_SV(ikl) + coefb) 1342 else if (TaT_SV(ikl).ge.ta2 .and. TaT_SV(ikl).lt.ta3) then 1343 ! ! if st > 0, melting induce smooth surface 1344 Z0_obs = exp(coefc*TaT_SV(ikl) + coefd) 903 1345 else 904 C + ********** 905 call SISVAT_zSn 906 C + ********** 1346 Z0_obs = z03 907 1347 endif 908 909 C + ********** 910 ! #ve call SISVAT_wEq('_zSn ',0) 911 C + ********** 912 913 ! Add a new Snow Layer 914 ! ==================== 915 916 DO ikl=1,knonv 917 918 isnoSV(ikl) = isnoSV(ikl) +NLaysv(ikl) 919 isn = isnoSV(ikl) 920 dzsnSV(ikl,isn) = dzsnSV(ikl,isn) * (1-NLaysv(ikl)) 921 . + Bdzssv(ikl) * NLaysv(ikl) 922 TsisSV(ikl,isn) = TsisSV(ikl,isn) * (1-NLaysv(ikl)) 923 . + min(TaT_SV(ikl),Tf_Sno) *NLaysv(ikl) 924 ro__SV(ikl,isn) = ro__SV(ikl,isn) * (1-NLaysv(ikl)) 925 . + Brossv(ikl) * NLaysv(ikl) 926 eta_SV(ikl,isn) = eta_SV(ikl,isn) * (1-NLaysv(ikl)) ! + 0. 927 agsnSV(ikl,isn) = agsnSV(ikl,isn) * (1-NLaysv(ikl)) ! + 0. 928 G1snSV(ikl,isn) = G1snSV(ikl,isn) * (1-NLaysv(ikl)) 929 . + BG1ssv(ikl) * NLaysv(ikl) 930 G2snSV(ikl,isn) = G2snSV(ikl,isn) * (1-NLaysv(ikl)) 931 . + BG2ssv(ikl) * NLaysv(ikl) 932 istoSV(ikl,isn) = istoSV(ikl,isn) * (1-NLaysv(ikl)) 933 . + max(zer0,sign(un_1,TaT_SV(ikl) 934 . -Tf_Sno-eps_21)) * istdSV(2) 935 . * NLaysv(ikl) 936 BufsSV(ikl) = BufsSV(ikl) * (1-NLaysv(ikl)) 937 NLaysv(ikl) = 0 938 939 940 END DO 941 942 943 ! Snow Pack Thickness 944 ! ------------------- 945 946 DO ikl=1,knonv 947 z_snsv(ikl) = 0.0 948 END DO 949 DO isn=1,nsno 950 DO ikl=1,knonv 951 z_snsv(ikl) = z_snsv(ikl) + dzsnSV(ikl,isn) 952 zzsnsv(ikl,isn) = z_snsv(ikl) 953 END DO 954 END DO 955 956 957 958 END IF ! SnoMod 959 960 961 962 ! Soil Albedo: Soil Humidity Correction 963 ! ========================================== 964 965 ! REFERENCE: McCumber and Pielke (1981), Pielke (1984) 966 ! ^^^^^^^^^ 967 DO ikl=1,knonv 968 albssv(ikl) = 969 . alb0SV(ikl) *(1.0-min(half,eta_SV( ikl,0) 970 . /etadSV(isotSV(ikl)))) 971 ! REMARK: Albedo of Water Surfaces (isotSV=0): 972 ! ^^^^^^ alb0SV := 2 X effective value, while 973 ! eta_SV := etadSV 974 END DO 975 976 977 ! Snow Pack Optical Properties 978 ! ============================ 979 980 IF (SnoMod) THEN 981 982 ! ****** 983 call SnOptP(jjtime) 984 ! ****** 1348 1349 Z0m_Sn=Z0_obs 1350 985 1351 986 1352 ELSE 987 DO ikl=1,knonv 988 sEX_sv(ikl,1) = 1.0 989 sEX_sv(ikl,0) = 0.0 990 albisv(ikl) = albssv(ikl) 991 END DO 992 END IF 993 994 995 996 ! Soil optical properties 997 ! ============================= 998 !Etienne: as in inlandis we do not call vgopt, we need to define 999 !the albedo alb_SV and to calculate the 1000 !absorbed Solar Radiation by Surfac (Normaliz)[-] SoSosv 1001 1002 1003 DO ikl=1,klonv 1004 1005 e_pRad = 2.5 * coszSV(ikl) ! exponential argument, 1006 ! V/nIR radiation partitioning, 1007 ! DR97, 2, eqn (2.53) & (2.54) 1008 e1pRad = 1.-exp(-e_pRad) ! exponential, V/nIR Rad. Part. 1009 exdRad= 1. 1010 1011 ! Visible Part of the Solar Radiation Spectrum (V, 0.4--0.7mi.m) 1012 A_Rad0 = 0.25 + 0.697 * e1pRad ! Absorbed Vis. Radiation 1013 absg_V = (1.-albisv(ikl))*(A_Rad0*exdRad) ! 1014 1015 ! Near-IR Part of the Solar Radiation Spectrum (nIR, 0.7--2.8mi.m) 1016 1017 A_Rad0 = 0.80 + 0.185 * e1pRad ! Absorbed nIR. Radiation 1018 absgnI = (1.-albisv(ikl))*(A_Rad0*exdRad) ! 1019 1020 SoSosv(ikl) = (absg_V+absgnI)*0.5d0 1021 1022 alb_SV(ikl) = albisv(ikl) 1023 1024 END DO 1025 1026 ! ********** 1027 ! #ve call SISVAT_wEq('SnOptP',0) 1028 ! ********** 1029 1030 1031 ! Surface Emissivity (Etienne: simplified calculation for landice) 1032 ! ============================================================= 1033 ! 1034 DO ikl=1,knonv 1035 LSnMsk = min( 1,isnoSV(ikl)) 1036 Eso_sv(ikl)= EmiSol*(1-LSnMsk)+EmiSno*LSnMsk ! Sol+Sno Emissivity 1037 emi_SV(ikl)= EmiSol*(1-LSnMsk) + EmiSno*LSnMsk 1038 END DO 1039 1040 1041 1042 1043 ! Upward IR (INPUT, from previous time step) 1044 ! =================================================================== 1045 1046 DO ikl=1,knonv 1047 ! #e1 Enrsvd(ikl) = - IRs_SV(ikl) 1048 IRupsv(ikl) = IRs_SV(ikl) 1049 END DO 1050 1051 1052 ! Turbulence 1053 ! ========== 1054 1055 ! Latent Heat of Vaporization/Sublimation 1056 ! --------------------------------------- 1057 1058 DO ikl=1,knonv 1059 SnoWat = min(isnoSV(ikl),0) 1060 Lx_H2O(ikl) = 1061 . (1.-SnoWat) * LhvH2O 1062 . + SnoWat *(LhsH2O * (1.-eta_SV(ikl,isnoSV(ikl))) 1063 . +LhvH2O * eta_SV(ikl,isnoSV(ikl)) ) 1064 END DO 1065 1066 1067 1068 1069 ! Aerodynamic Resistance (calculated from drags given by LMDZ) 1070 ! Commented because already calculated in surf_inlandsis_mod 1071 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1072 ! DO ikl=1,knonv 1073 ! ram_sv(ikl) = 1./(cdM_SV(ikl)*max(VV__SV(ikl),eps6)) 1074 ! rah_sv(ikl) = 1./(cdH_SV(ikl)*max(VV__SV(ikl),eps6)) 1075 ! END DO 1076 1077 1078 1079 ! Soil Energy Balance 1080 ! ===================== 1081 1082 1083 if (iflag_temp_inlandsis .eq. 0) then 1084 1085 call SISVAT_TSo 1086 1087 else 1088 DO ikl=1,knonv 1089 Tsf_SV(ikl)=Tsrfsv(ikl) 1090 END DO 1091 1092 call SISVAT_TS2 1093 1094 end if 1095 1096 1097 ! ********** 1098 ! #ve call SISVAT_wEq('_TSo ',0) 1099 ! ********** 1100 1101 1102 1103 ! Soil Water Potential 1104 ! ------------------------ 1105 1106 DO isl=-nsol,0 1107 DO ikl=1,knonv 1108 ist = isotSV(ikl) ! Soil Type 1109 psi_sv(ikl,isl) = psidSV(ist) ! DR97, Eqn.(3.34) 1110 . *(etadSV(ist) /max(eps6,eta_SV(ikl,isl))) ! 1111 . **bCHdSV(ist) ! 1112 1113 1114 ! Soil Hydraulic Conductivity 1115 ! --------------------------- 1116 1117 Khydsv(ikl,isl) = s2__SV(ist) ! DR97, Eqn.(3.35) 1118 . *(eta_SV(ikl,isl)**(2.*bCHdSV(ist)+3.)) ! 1119 END DO 1120 END DO 1121 1122 1123 ! Melting / Refreezing in the Snow Pack 1124 ! ===================================== 1125 1126 IF (SnoMod) THEN 1127 1128 ! ********** 1129 call SISVAT_qSn 1130 ! ********** 1131 1132 ! ********** 1133 ! #ve call SISVAT_wEq('_qSn ',0) 1134 ! ********** 1135 1136 1137 ! Snow Pack Thickness 1138 ! ------------------- 1139 1140 DO ikl=1,knonv 1141 z_snsv(ikl) = 0.0 1142 END DO 1143 DO isn=1,nsno 1144 DO ikl=1,knonv 1145 z_snsv(ikl) = z_snsv(ikl) + dzsnSV(ikl,isn) 1146 zzsnsv(ikl,isn) = z_snsv(ikl) 1147 END DO 1148 END DO 1149 1150 1151 ! Energy in Excess is added to the first Soil Layer 1152 ! ------------------------------------------------- 1153 DO ikl=1,knonv 1154 z_snsv(ikl) = max(zer0, 1155 . sign(un_1,eps6-z_snsv(ikl))) 1156 TsisSV(ikl,0) = TsisSV(ikl,0) + EExcsv(ikl) 1157 . /(rocsSV(isotSV(ikl)) 1158 . +rcwdSV*eta_SV(ikl,0)) 1159 EExcsv(ikl) = 0. 1160 END DO 1161 1162 1163 END IF 1164 1165 1166 ! Soil Water Balance 1167 ! ===================== 1168 1169 ! ********** 1170 call SISVAT_qSo 1171 ! #m0. (Wats_0,Wats_1,Wats_d) 1172 ! ********** 1173 1174 1175 ! Surface Fluxes 1176 ! ===================== 1177 1178 DO ikl=1,knonv 1179 IRdwsv(ikl)=IRd_SV(ikl)*Eso_sv(ikl) ! Downward IR 1180 ! IRdwsv(ikl)=tau_sv(ikl) *IRd_SV(ikl)*Eso_sv(ikl) ! Downward IR 1181 ! . +(1.0-tau_sv(ikl))*IRd_SV(ikl)*Evg_sv(ikl) ! ! Etienne, remove vegetation component 1182 IRupsv(ikl) = IRupsv(ikl) ! Upward IR 1183 IRu_SV(ikl) = -IRupsv(ikl) ! Upward IR 1184 . +IRd_SV(ikl) ! (effective) 1185 . -IRdwsv(ikl) ! (positive) 1186 1187 TBr_sv(ikl) =sqrt(sqrt(IRu_SV(ikl)/StefBo)) ! Brightness 1188 ! ! Temperature 1189 uts_SV(ikl) = (HSv_sv(ikl) +HSs_sv(ikl)) ! u*T* 1190 . /(rhT_SV(ikl) *cp) ! 1191 uqs_SV(ikl) = (HLv_sv(ikl) +HLs_sv(ikl)) ! u*q* 1192 . /(rhT_SV(ikl) *LhvH2O) ! 1193 LMO_SV(ikl) = TaT_SV(ikl)*(us__SV(ikl)**3) 1194 . /gravit/uts_SV(ikl)/vonKrm ! MO length 1195 1196 1197 ! Surface Temperature 1198 ! ^^^^^^^^^^^^^^^^^^^^ 1199 1200 IF (iflag_tsurf_inlandsis .EQ. 0) THEN 1201 1202 Tsrfsv(ikl) =TsisSV(ikl,isnoSV(ikl)) 1203 1204 ELSE IF (iflag_tsurf_inlandsis .GT. 0) THEN 1205 ! Etienne: extrapolation from the two uppermost levels: 1206 1207 if (isnoSV(ikl) >=2) then 1208 zm1=-dzsnSV(ikl,isnoSV(ikl))/2. 1209 zm2=-(dzsnSV(ikl,isnoSV(ikl)) + dzsnSV(ikl,isnoSV(ikl)-1)/2.) 1210 else if (isnoSV(ikl) .EQ. 1) then 1211 zm1=-dzsnSV(ikl,isnoSV(ikl))/2. 1212 zm2=-(dzsnSV(ikl,isnoSV(ikl))+dz_dSV(0)/2.) 1213 else 1214 zm1=-dz_dSV(0)/2. 1215 zm2=-(dz_dSV(0)+dz_dSV(-1)/2.) 1216 1217 end if 1218 1219 coefslope=(TsisSV(ikl,isnoSV(ikl))-TsisSV(ikl,isnoSV(ikl)-1)) 1220 . /(zm1-zm2) 1221 Tsrfsv(ikl)=TsisSV(ikl,isnoSV(ikl))+coefslope*(0. - zm1) 1222 1223 1224 ELSE !(default) 1225 1226 Tsrfsv(ikl) =TsisSV(ikl,isnoSV(ikl)) 1227 1228 END IF 1229 1230 1231 END DO 1232 1233 ! Snow Pack Properties (sphericity, dendricity, size) 1234 ! =================================================== 1235 1236 IF (SnoMod) THEN 1237 1238 if (discret_xf .AND. klonv.eq.1) then 1239 if(isnoSV(1).ge.1) then 1240 C + ********** 1241 call SISVAT_GSn 1242 C + ********** 1353 1354 Z0m_Sn=0.500e-3 ! default=0.500e-3m (tuning of MAR) 1355 1356 ENDIF 1357 1358 1359 1360 ! param = Z0_obs/1. ! param(s) | 1.(m/s)=TUNING 1361 ! #SZ Z0Sa_N = (us__SV(ikl) -0.2)*param ! 0.0001=TUNING 1362 ! #SZ. * max(zero,sign(unun,TfSnow-eps9 1363 ! #SZ. -TsisSV(ikl , isnoSV(ikl)))) 1364 !!#SZ Z0SaSi = max(zero,sign(unun,Z0Sa_N ))! 1 if erosion 1365 ! #SZ Z0SaSi = max(zero,sign(unun,zero -eps9 -uss_SV(ikl)))! 1366 ! #SZ Z0Sa_N = max(zero, Z0Sa_N) 1367 ! #SZ Z0SaSV(ikl) = 1368 ! #SZ. max(Z0SaSV(ikl) ,Z0SaSV(ikl) 1369 ! #SZ. + Z0SaSi*(Z0Sa_N-Z0SaSV(ikl))*exp(-dt__SV/43200.)) 1370 ! #SZ. - min(dz0_SV(ikl) , Z0SaSV(ikl)) 1371 1372 ! #SZ A_Fact = Z0SaSV(ikl) * 5.0/0.15 ! A=5 if h~10cm 1373 ! +... CAUTION: The influence of the sastrugi direction is not yet included 1374 1375 ! #SZ Z0m_Sn = Z0SaSV(ikl) ! 1376 ! #SZ. - Z0m_nu ! 1377 1378 ! +--Z0 Saltat.Regime over Snow (Shao & Lin, 1999, BLM 91 (46) p.222) 1379 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1380 ! #ZN sqrrZ0 = usthSV(ikl)/max( us__SV(ikl),0.001) 1381 ! #ZN sqrrZ0 = min( sqrrZ0 ,0.999) 1382 ! #ZN Z0mBSn = 0.55 *0.55 *exp(-sqrrZ0 *sqrrZ0) 1383 ! #ZN. *us__SV(ikl)* us__SV(ikl)*grvinv*0.5 1384 1385 ! +--Z0 Smooth + Saltat. Regime (Shao & Lin, 1999, BLM 91 (46) p.222) 1386 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1387 ! #ZN Z0enSV(ikl) = (Z0m_nu ** sqrrZ0 ) 1388 ! #ZN. * (Z0mBSn **(1.-sqrrZ0)) 1389 ! #ZN Z0enSV(ikl) = max(Z0enSV(ikl), Z0m_nu) 1390 1391 1392 ! +--Z0 Smooth Regime over Snow (Andreas etAl., 2004 1393 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ ams.confex.com/ams/pdfpapers/68601.pdf) 1394 ! #ZA Z0m_nu = 0.135*akmol / max(us__SV(ikl) , epsi) 1395 1396 ! +--Z0 Saltat.Regime over Snow (Andreas etAl., 2004 1397 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ ams.confex.com/ams/pdfpapers/68601.pdf) 1398 ! #ZA Z0mBSn = 0.035*u2star *grvinv 1399 1400 ! +--Z0 Smooth + Saltat. Regime (Andreas etAl., 2004 1401 ! ( used by Erosion) ams.confex.com/ams/pdfpapers/68601.pdf) 1402 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1403 ! #ZA Z0enSV(ikl) = Z0m_nu 1404 ! #ZA. + Z0mBSn 1405 1406 ! +--Z0 Rough Regime over Snow (Andreas etAl., 2004 1407 ! + (.NOT. used by Erosion) ams.confex.com/ams/pdfpapers/68601.pdf) 1408 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1409 !!#ZA u2star = (us__SV(ikl) -0.1800) / 0.1 1410 !!#ZA Z0m_Sn =A_Fact*Z0mBSn *exp(-u2star*u2star) 1411 ! #ZA Z0m_90 =(10.-0.025*VVs_SV(ikl)/5.) 1412 ! #ZA. *exp(-0.4/sqrt(.00275+.00001*max(0.,VVs_SV(ikl)-5.))) 1413 ! #ZA Z0m_Sn = DDs_SV(ikl)* Z0m_90 / 45. 1414 ! #ZA. - DDs_SV(ikl)*DDs_SV(ikl)* Z0m_90 /(90.*90.) 1415 1416 1417 1418 1419 ! +--Z0 (Erosion) over Snow (instantaneous) 1420 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1421 Z0e_SV(ikl) = Z0enSV(ikl) 1422 1423 ! +--Momentum Roughness Length (Etienne: changes wrt original SISVAT) 1424 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1425 Z0mnSV(ikl) = Z0m_nu *(1-SnoMsk) & ! Ice z0 1426 + (Z0m_Sn)*SnoMsk ! Snow Sastrugi Form and Snow Erosion 1427 1428 1429 ! +--GIS Roughness Length 1430 ! + ^^^^^^^^^^^^^^^^^^^^^ 1431 ! #GL Z0mnSV(ikl) = 1432 ! #GL. (1-LSmask(ikl)) * Z0mnSV(ikl) 1433 ! #GL. + LSmask(ikl) * max(Z0mnSV(ikl),max(Z0_GIM, 1434 ! #GL. Z0_GIM+ 1435 ! #GL. (0.0032-Z0_GIM)*(ro__SV(ikl,isnoSV(ikl))-600.) ! 1436 ! #GL. /(920.00 -600.))) ! 1437 1438 ! +--Mom. Roughness Length, Instantaneous 1439 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1440 Z0m_SV(ikl) = Z0mnSV(ikl) ! Z0mnSV instant. 1441 1442 1443 ! +--Roughness Length for Scalars 1444 ! + ---------------------------- 1445 1446 Z0hnSV(ikl) = Z0mnSV(ikl)/ 7.4 1447 1448 IF (is_ok_z0h_rn) THEN 1449 1450 rstar = Z0mnSV(ikl) * us__SV(ikl) / akmol 1451 rstar = max(epsi,min(rstar,R_1000)) 1452 alors = log(rstar) 1453 rstar0 = 1.250e0 * max(zero,sign(unun,0.135e0 - rstar)) & 1454 +(1. - max(zero,sign(unun,0.135e0 - rstar))) & 1455 *(0.149e0 * max(zero,sign(unun,2.500e0 - rstar)) & 1456 + 0.317e0 & 1457 *(1. - max(zero,sign(unun,2.500e0 - rstar)))) 1458 rstar1 = 0. * max(zero,sign(unun,0.135e0 - rstar)) & 1459 +(1. - max(zero,sign(unun,0.135e0 - rstar))) & 1460 *(-0.55e0 * max(zero,sign(unun,2.500e0 - rstar)) & 1461 - 0.565 & 1462 *(1. - max(zero,sign(unun,2.500e0 - rstar)))) 1463 rstar2 = 0. * max(zero,sign(unun,0.135e0 - rstar)) & 1464 +(1. - max(zero,sign(unun,0.135e0 - rstar))) & 1465 *(0. * max(zero,sign(unun,2.500e0 - rstar)) & 1466 - 0.183 & 1467 *(unun - max(zero,sign(unun,2.500e0 - rstar)))) 1468 1469 1470 1471 !XF #RN (is_ok_z0h_rn) does not work well over bare ice 1472 !XF MAR is then too warm and not enough melt 1473 1474 if(ro__SV(ikl,isnoSV(ikl))>50 & 1475 .and.ro__SV(ikl,isnoSV(ikl))<roSdSV)then 1476 1477 Z0hnSV(ikl) = max(zero & 1478 , sign(unun,zzsnsv(ikl,isnoSV(ikl))-epsi)) & 1479 * exp(rstar0+rstar1*alors+rstar2*alors*alors) & 1480 * 0.001e0 + Z0hnSV(ikl) * ( 1. - max(zero & 1481 , sign(unun,zzsnsv(ikl,isnoSV(ikl))-epsi))) 1482 1243 1483 endif 1244 else 1245 C + ********** 1246 call SISVAT_GSn 1247 C + ********** 1248 endif 1249 1250 1251 END IF 1252 1253 1254 ! Roughness Length for next time step 1255 !==================================== 1256 1257 ! Note that in INLANDSIS, we treat only ice covered surfaces so calculation 1258 ! of z0 is much simpler (no subgrid fraction of ocean or land) 1259 ! old calculations are commented below 1260 1261 1262 C +--Roughness Length for Momentum 1263 C + ----------------------------- 1264 1265 ! ETIENNE WARNING: changes have been made wrt original SISVAT 1266 1267 C +--Land+Sea-Ice / Ice-free Sea Mask 1268 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1269 DO ikl=1,knonv 1270 IcIndx(ikl) = 0 1271 ENDDO 1272 DO isn=1,nsno 1273 DO ikl=1,knonv 1274 1275 IcIndx(ikl) = max(IcIndx(ikl), 1276 . isn*max(0, 1277 . sign(1, 1278 . int(ro__SV(ikl,isn)-900.)))) 1279 ENDDO 1280 ENDDO 1281 1282 DO ikl=1,knonv 1283 LISmsk = 1. ! in inlandsis, land only 1284 IceMsk = max(0,sign(1 ,IcIndx(ikl)-1) ) 1285 SnoMsk = max(min(isnoSV(ikl)-iiceSV(ikl),1),0) 1286 1287 1288 C +--Z0 Smooth Regime over Snow (Andreas 1995, CRREL Report 95-16, p. 8) 1289 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1290 Z0m_nu = 5.e-5 ! z0s~(10-d)*exp(-vonkar/sqrt(1.1e-03)) 1291 1292 C +--Z0 Saltat.Regime over Snow (Gallee et al., 2001, BLM 99 (19) p.11) 1293 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1294 1295 u2star = us__SV(ikl) *us__SV(ikl) 1296 Z0mBSn = u2star *0.536e-3 - 61.8e-6 1297 Z0mBSn = max(Z0mBS0 ,Z0mBSn) 1298 1299 C +--Z0 Smooth + Saltat. Regime 1300 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1301 Z0enSV(ikl) = Z0m_nu 1302 . + Z0mBSn 1303 1304 1305 ! Calculation of snow roughness length 1306 !===================================== 1307 IF (iflag_z0m_snow .EQ. 0) THEN 1308 1309 Z0m_Sn=prescribed_z0m_snow 1310 1311 ELSE IF (iflag_z0m_snow .EQ. 1) THEN 1312 1313 Z0m_Sn=Z0enSV(ikl) 1314 1315 ELSE IF (iflag_z0m_snow .EQ. 2) THEN 1316 1317 C +--Rough Snow Surface Roughness Length (Variable Sastrugi Height) 1318 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1319 A_Fact = 1.0000 ! Andreas et al., 2004, p.4 1320 ! ams.confex.com/ams/pdfpapers/68601.pdf 1321 1322 ! Parameterization of z0 dependance on Temperature (C. Amory, 2017) 1323 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1324 ! Z0=f(T) deduced from observations, Adelie Land, dec2012-dec2013 1325 1326 1327 coefa = 0.1658 !0.1862 !Ant 1328 coefb = -50.3869 !-55.7718 !Ant 1329 ta1 = 253.15 !255. Ant 1330 ta2 = 273.15 1331 ta3 = 273.15+3 1332 z01 = exp(coefa*ta1 + coefb) !~0.2 ! ~0.25 mm 1333 z02 = exp(coefa*ta2 + coefb) !~6 !~7 mm 1334 z03 = z01 1335 coefc = log(z03/z02)/(ta3-ta2) 1336 coefd = log(z03)-coefc*ta3 1337 1338 if (TaT_SV(ikl) .lt. ta1) then 1339 Z0_obs = z01 1340 else if (TaT_SV(ikl).ge.ta1 .and. TaT_SV(ikl).lt.ta2) then 1341 Z0_obs = exp(coefa*TaT_SV(ikl) + coefb) 1342 else if (TaT_SV(ikl).ge.ta2 .and. TaT_SV(ikl).lt.ta3) then 1343 ! if st > 0, melting induce smooth surface 1344 Z0_obs = exp(coefc*TaT_SV(ikl) + coefd) 1345 else 1346 Z0_obs = z03 1347 endif 1348 1349 Z0m_Sn=Z0_obs 1350 1351 1352 ELSE 1353 1354 Z0m_Sn=0.500e-3 ! default=0.500e-3m (tuning of MAR) 1355 1356 ENDIF 1357 1358 1359 1360 ! param = Z0_obs/1. ! param(s) | 1.(m/s)=TUNING 1361 c #SZ Z0Sa_N = (us__SV(ikl) -0.2)*param ! 0.0001=TUNING 1362 c #SZ. * max(zero,sign(unun,TfSnow-eps9 1363 c #SZ. -TsisSV(ikl , isnoSV(ikl)))) 1364 !!#SZ Z0SaSi = max(zero,sign(unun,Z0Sa_N ))! 1 if erosion 1365 c #SZ Z0SaSi = max(zero,sign(unun,zero -eps9 -uss_SV(ikl)))! 1366 c #SZ Z0Sa_N = max(zero, Z0Sa_N) 1367 c #SZ Z0SaSV(ikl) = 1368 c #SZ. max(Z0SaSV(ikl) ,Z0SaSV(ikl) 1369 c #SZ. + Z0SaSi*(Z0Sa_N-Z0SaSV(ikl))*exp(-dt__SV/43200.)) 1370 c #SZ. - min(dz0_SV(ikl) , Z0SaSV(ikl)) 1371 1372 c #SZ A_Fact = Z0SaSV(ikl) * 5.0/0.15 ! A=5 if h~10cm 1373 C +... CAUTION: The influence of the sastrugi direction is not yet included 1374 1375 c #SZ Z0m_Sn = Z0SaSV(ikl) ! 1376 c #SZ. - Z0m_nu ! 1377 1378 C +--Z0 Saltat.Regime over Snow (Shao & Lin, 1999, BLM 91 (46) p.222) 1379 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1380 c #ZN sqrrZ0 = usthSV(ikl)/max( us__SV(ikl),0.001) 1381 c #ZN sqrrZ0 = min( sqrrZ0 ,0.999) 1382 c #ZN Z0mBSn = 0.55 *0.55 *exp(-sqrrZ0 *sqrrZ0) 1383 c #ZN. *us__SV(ikl)* us__SV(ikl)*grvinv*0.5 1384 1385 C +--Z0 Smooth + Saltat. Regime (Shao & Lin, 1999, BLM 91 (46) p.222) 1386 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1387 c #ZN Z0enSV(ikl) = (Z0m_nu ** sqrrZ0 ) 1388 c #ZN. * (Z0mBSn **(1.-sqrrZ0)) 1389 c #ZN Z0enSV(ikl) = max(Z0enSV(ikl), Z0m_nu) 1390 1391 1392 C +--Z0 Smooth Regime over Snow (Andreas etAl., 2004 1393 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ ams.confex.com/ams/pdfpapers/68601.pdf) 1394 c #ZA Z0m_nu = 0.135*akmol / max(us__SV(ikl) , epsi) 1395 1396 C +--Z0 Saltat.Regime over Snow (Andreas etAl., 2004 1397 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ ams.confex.com/ams/pdfpapers/68601.pdf) 1398 c #ZA Z0mBSn = 0.035*u2star *grvinv 1399 1400 C +--Z0 Smooth + Saltat. Regime (Andreas etAl., 2004 1401 ! ( used by Erosion) ams.confex.com/ams/pdfpapers/68601.pdf) 1402 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1403 c #ZA Z0enSV(ikl) = Z0m_nu 1404 c #ZA. + Z0mBSn 1405 1406 C +--Z0 Rough Regime over Snow (Andreas etAl., 2004 1407 C + (.NOT. used by Erosion) ams.confex.com/ams/pdfpapers/68601.pdf) 1408 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1409 !!#ZA u2star = (us__SV(ikl) -0.1800) / 0.1 1410 !!#ZA Z0m_Sn =A_Fact*Z0mBSn *exp(-u2star*u2star) 1411 c #ZA Z0m_90 =(10.-0.025*VVs_SV(ikl)/5.) 1412 c #ZA. *exp(-0.4/sqrt(.00275+.00001*max(0.,VVs_SV(ikl)-5.))) 1413 c #ZA Z0m_Sn = DDs_SV(ikl)* Z0m_90 / 45. 1414 c #ZA. - DDs_SV(ikl)*DDs_SV(ikl)* Z0m_90 /(90.*90.) 1415 1416 1417 1418 1419 C +--Z0 (Erosion) over Snow (instantaneous) 1420 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 1421 Z0e_SV(ikl) = Z0enSV(ikl) 1422 1423 C +--Momentum Roughness Length (Etienne: changes wrt original SISVAT) 1424 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1425 Z0mnSV(ikl) = Z0m_nu *(1-SnoMsk) ! Ice z0 1426 . + (Z0m_Sn)*SnoMsk ! Snow Sastrugi Form and Snow Erosion 1427 1428 1429 C +--GIS Roughness Length 1430 C + ^^^^^^^^^^^^^^^^^^^^^ 1431 c #GL Z0mnSV(ikl) = 1432 c #GL. (1-LSmask(ikl)) * Z0mnSV(ikl) 1433 c #GL. + LSmask(ikl) * max(Z0mnSV(ikl),max(Z0_GIM, 1434 c #GL. Z0_GIM+ 1435 c #GL. (0.0032-Z0_GIM)*(ro__SV(ikl,isnoSV(ikl))-600.) ! 1436 c #GL. /(920.00 -600.))) ! 1437 1438 C +--Mom. Roughness Length, Instantaneous 1439 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1440 Z0m_SV(ikl) = Z0mnSV(ikl) ! Z0mnSV instant. 1441 1442 1443 C +--Roughness Length for Scalars 1444 C + ---------------------------- 1445 1446 Z0hnSV(ikl) = Z0mnSV(ikl)/ 7.4 1447 1448 IF (is_ok_z0h_rn) THEN 1449 1450 rstar = Z0mnSV(ikl) * us__SV(ikl) / akmol 1451 rstar = max(epsi,min(rstar,R_1000)) 1452 alors = log(rstar) 1453 rstar0 = 1.250e0 * max(zero,sign(unun,0.135e0 - rstar)) 1454 . +(1. - max(zero,sign(unun,0.135e0 - rstar))) 1455 . *(0.149e0 * max(zero,sign(unun,2.500e0 - rstar)) 1456 . + 0.317e0 1457 . *(1. - max(zero,sign(unun,2.500e0 - rstar)))) 1458 rstar1 = 0. * max(zero,sign(unun,0.135e0 - rstar)) 1459 . +(1. - max(zero,sign(unun,0.135e0 - rstar))) 1460 . *(-0.55e0 * max(zero,sign(unun,2.500e0 - rstar)) 1461 . - 0.565 1462 . *(1. - max(zero,sign(unun,2.500e0 - rstar)))) 1463 rstar2 = 0. * max(zero,sign(unun,0.135e0 - rstar)) 1464 . +(1. - max(zero,sign(unun,0.135e0 - rstar))) 1465 . *(0. * max(zero,sign(unun,2.500e0 - rstar)) 1466 . - 0.183 1467 . *(unun - max(zero,sign(unun,2.500e0 - rstar)))) 1468 1469 1470 1471 !XF #RN (is_ok_z0h_rn) does not work well over bare ice 1472 !XF MAR is then too warm and not enough melt 1473 1474 if(ro__SV(ikl,isnoSV(ikl))>50 1475 . .and.ro__SV(ikl,isnoSV(ikl))<roSdSV)then 1476 1477 Z0hnSV(ikl) = max(zero 1478 . , sign(unun,zzsnsv(ikl,isnoSV(ikl))-epsi)) 1479 . * exp(rstar0+rstar1*alors+rstar2*alors*alors) 1480 . * 0.001e0 + Z0hnSV(ikl) * ( 1. - max(zero 1481 . , sign(unun,zzsnsv(ikl,isnoSV(ikl))-epsi))) 1482 1483 endif 1484 1485 1486 ENDIF 1487 1488 Z0h_SV(ikl) = Z0hnSV(ikl) 1489 1490 1491 c #MT Z0m_SV(ikl) = max(2.0e-6 ,Z0m_SV(ikl)) ! Min Z0_m (Garrat Scheme) 1492 ! Z0m_SV(ikl) = min(Z0m_SV(ikl),za__SV(ikl)*0.3333) 1493 1494 1495 END DO 1496 1497 1498 return 1499 end 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1484 1485 1486 ENDIF 1487 1488 Z0h_SV(ikl) = Z0hnSV(ikl) 1489 1490 1491 ! #MT Z0m_SV(ikl) = max(2.0e-6 ,Z0m_SV(ikl)) ! Min Z0_m (Garrat Scheme) 1492 ! Z0m_SV(ikl) = min(Z0m_SV(ikl),za__SV(ikl)*0.3333) 1493 1494 1495 END DO 1496 1497 1498 return 1499 end subroutine inlandsis 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_bsn.f90
r5245 r5246 1 2 3 subroutine SISVAT_BSn4 5 C +------------------------------------------------------------------------+6 C | MAR SISVAT_BSn 04-apr-2020 MAR |7 C | SubRoutine SISVAT_BSn treats Snow Erosion |8 C | (not deposition anymore since 2-jun 2018) |9 C | |10 C | SISVAT_bsn computes the snow erosion mass according to both the |11 C | theoretical maximum erosion amount computed in inlandsis and the |12 C | availability of snow (currently in the uppermost snow layer only) |13 C | |14 C +------------------------------------------------------------------------+15 16 17 18 19 C +--General Variables20 C + =================21 1 22 use VARphy23 use VAR_SV24 use VARdSV25 use VARxSV26 use VARySV27 28 29 IMPLICIT NONE30 2 31 C +--Local Variables 32 C + =============== 33 34 35 integer ikl ,isn 36 real h_mmWE ! Eroded Snow Layer Min Thickness 37 real dbsaux(knonv) ! Drift Amount (Dummy Variable) 38 real dzweqo,dzweqn,bsno_x ! Conversion variables for erosion 39 real dz_new,rho_new 40 real snofOK ! Threshd Snow Fall 41 real Fac ! Correction factor for erosion 42 real densif ! Densification rate if erosion 43 44 C +--DATA 45 C + ==== 46 47 data h_mmWE / 0.01e00 / ! Eroded Snow Layer Min Thickness 48 49 C +--EROSION 50 C + ======= 51 52 !DO isn = nsno,2,-1 53 DO ikl = 1,knonv 54 55 isn = isnoSV(ikl) 56 dzweqo = dzsnSV(ikl,isn) *ro__SV(ikl,isn) ! [kg/m2, mm w.e.] 57 58 bsno_x = min(0.,dbs_SV(ikl)) 59 c Fac = min(1.,max(1-(ro__SV(ikl,isn)/700.),0.)**2) 60 c Fac = min(1.,max(1-(qsnoSV(ikl)*1000/30.),0.)) 61 c bsno_x = bsno_x*Fac 62 63 dzweqn = dzweqo + bsno_x 64 dzweqn = max(dzweqn,h_mmWE) 65 dzweqn = min(dzweqn,dzweqo) 66 cXF 67 dbs_SV(ikl) = dbs_SV(ikl) +(dzweqo -dzweqn) 68 dbs_Er(ikl) = dbs_Er(ikl) +(dzweqo -dzweqn) 69 dzsnSV(ikl,isn) = dzweqn 70 . /max(epsi,ro__SV(ikl,isn)) 71 72 ! Densification of the uppermost snow layer if erosion: 73 if((dzweqo-dzweqn)>0 .and. 74 . dzsnSV(ikl,isn)>0 .and. 75 . ro__SV(ikl,max(1,isnoSV(ikl)))<roBdSV) then 76 77 !characteristic time scale for drifting snow compaction set to 24h 78 !linear densification rate [kg/m3/s] over 24h 79 densif = (450. - frsno) / (3600*24) 80 81 !Attenuation of compaction rate from 450 to 500 kg/m3 82 Fac = 1-((ro__SV(ikl,max(1,isnoSV(ikl))) 83 . -roBdSV)/(500.-roBdSV)) 84 Fac = max(0.,min(1.,Fac)) 85 86 if (ro__SV(ikl,max(1,isnoSV(ikl)))>roBdSV) then 87 densif=densif*Fac 88 endif 89 90 rho_new = min(roBdSV,ro__SV(ikl,isn)+densif*dt__SV) 91 dz_new = dzsnSV(ikl,isn)*ro__SV(ikl,isn)/rho_new 92 ro__SV(ikl,isn)=rho_new 93 dzsnSV(ikl,isn)=dz_new 94 endif 95 96 if(dzsnSV(ikl,isn)>0 .and.dzsnSV(ikl,isn)<0.0001)then 97 dbs_SV(ikl) = dbs_SV(ikl)+ dzsnSV(ikl,isn)*ro__SV(ikl,isn) 98 dbs_Er(ikl) = dbs_Er(ikl)+ dzsnSV(ikl,isn)*ro__SV(ikl,isn) 99 dzsnSV(ikl,isn) = 0 100 ro__SV(ikl,isn) = 0 101 isnoSV(ikl) = max(0,isnoSV(ikl) - 1) 102 endif 103 104 END DO 105 !END DO 106 107 return 108 END 3 subroutine SISVAT_BSn 4 5 ! +------------------------------------------------------------------------+ 6 ! | MAR SISVAT_BSn 04-apr-2020 MAR | 7 ! | SubRoutine SISVAT_BSn treats Snow Erosion | 8 ! | (not deposition anymore since 2-jun 2018) | 9 ! | | 10 ! | SISVAT_bsn computes the snow erosion mass according to both the | 11 ! | theoretical maximum erosion amount computed in inlandsis and the | 12 ! | availability of snow (currently in the uppermost snow layer only) | 13 ! | | 14 ! +------------------------------------------------------------------------+ 15 16 17 18 19 ! +--General Variables 20 ! + ================= 21 22 use VARphy 23 use VAR_SV 24 use VARdSV 25 use VARxSV 26 use VARySV 27 28 29 IMPLICIT NONE 30 31 ! +--Local Variables 32 ! + =============== 33 34 35 integer :: ikl ,isn 36 real :: h_mmWE ! Eroded Snow Layer Min Thickness 37 real :: dbsaux(knonv) ! Drift Amount (Dummy Variable) 38 real :: dzweqo,dzweqn,bsno_x ! Conversion variables for erosion 39 real :: dz_new,rho_new 40 real :: snofOK ! Threshd Snow Fall 41 real :: Fac ! Correction factor for erosion 42 real :: densif ! Densification rate if erosion 43 44 ! +--DATA 45 ! + ==== 46 47 data h_mmWE / 0.01e00 / ! Eroded Snow Layer Min Thickness 48 49 ! +--EROSION 50 ! + ======= 51 52 ! !DO isn = nsno,2,-1 53 DO ikl = 1,knonv 54 55 isn = isnoSV(ikl) 56 dzweqo = dzsnSV(ikl,isn) *ro__SV(ikl,isn) ! [kg/m2, mm w.e.] 57 58 bsno_x = min(0.,dbs_SV(ikl)) 59 ! Fac = min(1.,max(1-(ro__SV(ikl,isn)/700.),0.)**2) 60 ! Fac = min(1.,max(1-(qsnoSV(ikl)*1000/30.),0.)) 61 ! bsno_x = bsno_x*Fac 62 63 dzweqn = dzweqo + bsno_x 64 dzweqn = max(dzweqn,h_mmWE) 65 dzweqn = min(dzweqn,dzweqo) 66 !XF 67 dbs_SV(ikl) = dbs_SV(ikl) +(dzweqo -dzweqn) 68 dbs_Er(ikl) = dbs_Er(ikl) +(dzweqo -dzweqn) 69 dzsnSV(ikl,isn) = dzweqn & 70 /max(epsi,ro__SV(ikl,isn)) 71 72 ! ! Densification of the uppermost snow layer if erosion: 73 if((dzweqo-dzweqn)>0 .and. & 74 dzsnSV(ikl,isn)>0 .and. & 75 ro__SV(ikl,max(1,isnoSV(ikl)))<roBdSV) then 76 77 ! !characteristic time scale for drifting snow compaction set to 24h 78 ! !linear densification rate [kg/m3/s] over 24h 79 densif = (450. - frsno) / (3600*24) 80 81 ! !Attenuation of compaction rate from 450 to 500 kg/m3 82 Fac = 1-((ro__SV(ikl,max(1,isnoSV(ikl))) & 83 -roBdSV)/(500.-roBdSV)) 84 Fac = max(0.,min(1.,Fac)) 85 86 if (ro__SV(ikl,max(1,isnoSV(ikl)))>roBdSV) then 87 densif=densif*Fac 88 endif 89 90 rho_new = min(roBdSV,ro__SV(ikl,isn)+densif*dt__SV) 91 dz_new = dzsnSV(ikl,isn)*ro__SV(ikl,isn)/rho_new 92 ro__SV(ikl,isn)=rho_new 93 dzsnSV(ikl,isn)=dz_new 94 endif 95 96 if(dzsnSV(ikl,isn)>0 .and.dzsnSV(ikl,isn)<0.0001)then 97 dbs_SV(ikl) = dbs_SV(ikl)+ dzsnSV(ikl,isn)*ro__SV(ikl,isn) 98 dbs_Er(ikl) = dbs_Er(ikl)+ dzsnSV(ikl,isn)*ro__SV(ikl,isn) 99 dzsnSV(ikl,isn) = 0 100 ro__SV(ikl,isn) = 0 101 isnoSV(ikl) = max(0,isnoSV(ikl) - 1) 102 endif 103 104 END DO 105 ! !END DO 106 107 return 108 END SUBROUTINE SISVAT_BSn -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_gsn.f90
r5245 r5246 1 2 subroutine SISVAT_GSn 3 4 C +------------------------------------------------------------------------+ 5 C | MAR SISVAT_GSn 20-09-2003 MAR | 6 C | SubRoutine SISVAT_GSn simulates SNOW Metamorphism | 7 C +------------------------------------------------------------------------+ 8 C | | 9 C | PARAMETERS: knonv: Total Number of columns = | 10 C | ^^^^^^^^^^ = Total Number of continental grid boxes | 11 C | X Number of Mosaic Cell per grid box | 12 C | | 13 C | INPUT / isnoSV = total Nb of Ice/Snow Layers | 14 C | OUTPUT: iiceSV = total Nb of Ice Layers | 15 C | ^^^^^^ istoSV = 0,...,5 : Snow History (see istdSV data) | 16 C | | 17 C | INPUT: TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 18 C | ^^^^^ & Snow Temperatures (layers 1,2,...,nsno) [K] | 19 C | ro__SV : Soil/Snow Volumic Mass [kg/m3] | 20 C | eta_SV : Soil/Snow Water Content [m3/m3] | 21 C | slopSV : Surface Slope [-] | 22 C | dzsnSV : Snow Layer Thickness [m] | 23 C | dt__SV2 : Time Step [s] | 24 C | | 25 C | INPUT / G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer | 26 C | OUTPUT: G2snSV : Sphericity (>0) or Size of Snow Layer | 27 C | ^^^^^^ | 28 C | | 29 C | Formalisme adopte pour la Representation des Grains: | 30 C | Formalism for the Representation of Grains: | 31 C | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | 32 C | | 33 C | 1 - -1 Neige Fraiche | 34 C | / \ | ------------- | 35 C | / \ | Dendricite decrite par Dendricite | 36 C | / \ | Dendricity et Sphericite | 37 C | / \ | | 38 C | 2---------3 - 0 described by Dendricity | 39 C | and Sphericity | 40 C | |---------| | 41 C | 0 1 | 42 C | Sphericite | 43 C | Sphericity | 44 C | | 45 C | 4---------5 - | 46 C | | | | | 47 C | | | | Diametre (1/10eme de mm) (ou Taille) | 48 C | | | | Diameter (1/10th of mm) (or Size ) | 49 C | | | | | 50 C | | | | Neige non dendritique | 51 C | 6---------7 - --------------------- | 52 C | decrite par Sphericite | 53 C | et Taille | 54 C | described by Sphericity | 55 C | and Size | 56 C | | 57 C | Les Variables du Modele: | 58 C | Model Variables: | 59 C | ^^^^^^^^^^^^^^^^^^^^^^^^ | 60 C | Cas Dendritique Cas non Dendritique | 61 C | | 62 C | G1snSV : Dendricite G1snSV : Sphericite | 63 C | G2snSV : Sphericite G2snSV : Taille (1/10e mm) | 64 C | Size | 65 C | | 66 C | Cas Dendritique/ Dendritic Case | 67 C | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | 68 C | Dendricite(Dendricity) G1snSV | 69 C | varie de -G1_dSV (-99 par defaut / etoile) a 0 | 70 C | division par -G1_dSV pour obtenir des valeurs entre 1 et 0 | 71 C | varies from -G1_dSV (default -99 / fresh snow) to 0 | 72 C | division by -G1_dSV to obtain values between 1 and 0 | 73 C | | 74 C | Sphericite(Sphericity) G2snSV | 75 C | varie de 0 (cas completement anguleux) | 76 C | a G1_dSV (99 par defaut, cas spherique) | 77 C | division par G1_dSV pour obtenir des valeurs entre 0 et 1 | 78 C | varies from 0 (full faceted) to G1_dSV | 79 C | | 80 C | Cas non Dendritique / non Dendritic Case | 81 C | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | 82 C | Sphericite(Sphericity) G1snSV | 83 C | varie de 0 (cas completement anguleux) | 84 C | a G1_dSV (99 par defaut, cas spherique) | 85 C | division par G1_dSV pour obtenir des valeurs entre 0 et 1 | 86 C | varies from 0 (full faceted) to G1_dSV | 87 C | | 88 C | Taille (Size) G2snSV | 89 C | superieure a ADSdSV (.4 mm) et ne fait que croitre | 90 C | greater than ADSdSV (.4 mm) always increases | 91 C | | 92 C | Exemples: Points caracteristiques des Figures ci-dessus | 93 C | ^^^^^^^^^ | 94 C | | 95 C | G1snSV G2snSV dendricite sphericite taille | 96 C | dendricity sphericity size | 97 C | ------------------------------------------------------------------ | 98 C | [1/10 mm] | 99 C | 1 -G1_dSV sph3SN 1 0.5 | 100 C | 2 0 0 0 0 | 101 C | 3 0 G1_dSV 0 1 | 102 C | 4 0 ADSdSV 0 4. | 103 C | 5 G1_dSV ADSdSV-vsphe1 1 3. | 104 C | 6 0 -- 0 -- | 105 C | 7 G1_dSV -- 1 -- | 106 C | | 107 C | par defaut: G1_dSV=99. | 108 C | sph3SN=50. | 109 C | ADSdSV= 4. | 110 C | vsphe1=1. | 111 C | | 112 C | Methode: | 113 C | ^^^^^^^^ | 114 C | 1. Evolution Types de Grains selon Lois de Brun et al. (1992): | 115 C | Grain metamorphism according to Brun et al. (1992): | 116 C | Plusieurs Cas sont a distiguer / the different Cases are: | 117 C | 1.1 Metamorphose Neige humide / wet Snow | 118 C | 1.2 Metamorphose Neige seche / dry Snow | 119 C | 1.2.1 Gradient faible / low Temperature Gradient | 120 C | 1.2.2 Gradient moyen / moderate Temperature Gradient | 121 C | 1.2.3 Gradient fort / high Temperature Gradient | 122 C | Dans chaque Cas on separe Neige Dendritique et non Dendritique | 123 C | le Passage Dendritique -> non Dendritique | 124 C | se fait lorsque G1snSV devient > 0 | 125 C | the Case of Dentritic or non Dendritic Snow is treated separately | 126 C | the Limit Dentritic -> non Dendritic is reached when G1snSV > 0 | 127 C | | 128 C | 2. Tassement: Loi de Viscosite adaptee selon le Type de Grains | 129 C | Snow Settling: Viscosity depends on the Grain Type | 130 C | | 131 C | 3. Update Variables historiques (cas non dendritique seulement) | 132 C | nhSNow defaut | 133 C | 0 Cas normal | 134 C | istdSV(1) 1 Grains anguleux / faceted cristal | 135 C | istdSV(2) 2 Grains ayant ete en presence d eau liquide | 136 C | mais n'ayant pas eu de caractere anguleux / | 137 C | liquid water and no faceted cristals before | 138 C | istdSV(3) 3 Grains ayant ete en presence d eau liquide | 139 C | ayant eu auparavant un caractere anguleux / | 140 C | liquid water and faceted cristals before | 141 C | | 142 C | REFER. : Brun et al. 1989, J. Glaciol 35 pp. 333--342 | 143 C | ^^^^^^^^ Brun et al. 1992, J. Glaciol 38 pp. 13-- 22 | 144 C | (CROCUS Model, adapted to MAR at CEN by H.Gallee) | 145 C | | 146 C | REFER. : Marbouty, D. 1980, J. Glaciol 26 pp. xxx--xxx | 147 C | ^^^^^^^^ (CROCUS Model, adapted to MAR at CEN by H.Gallee) | 148 C | (for angular shapes) | 149 C | | 150 C | Preprocessing Option: SISVAT IO (not always a standard preprocess.) | 151 C | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ | 152 C | FILE | CONTENT | 153 C | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ | 154 C | # SISVAT_GSn.vp | #vp: OUTPUT/Verification: Snow Properties | 155 C | | unit 47, SubRoutines SISVAT_zSn, _GSn | 156 C | # stdout | #wp: OUTPUT/Verification: Snow Properties | 157 C | | unit 6, SubRoutine SISVAT_GSn | 158 C | | 159 C +------------------------------------------------------------------------+ 160 161 162 163 164 C +--Global Variables 165 C + ================ 166 167 use VARphy 168 use VAR_SV 169 use VARdSV 170 use VAR0SV 171 use VARxSV 172 use VARtSV 173 174 175 IMPLICIT NONE 176 177 178 179 C +--INPUT/OUTPUT 180 C + ------------ 181 182 183 C +--OUTPUT 184 C + ------ 185 186 integer dt__SV2 187 188 189 C +--Local Variables 190 C + ================ 191 192 logical vector ! 193 integer ikl ! 194 integer isn ,isnp ! 195 integer istoOK ! 196 real G1_bak,G2_bak ! Old Values of G1, G2 197 real ro_dry(knonv, nsno) ! Dry Density [g/cm3] 198 real etaSno(knonv, nsno) ! Liquid Water Content [g/cm2] 199 real SnMass(knonv) ! Snow Mass [kg/m2] 200 real dTsndz ! Temperature Gradient 201 real sWater ! Water Content [%] 202 real exp1Wa ! 203 real dDENDR ! Dendricity Increment 204 real DENDRn ! Normalized Dendricity 205 real SPHERn ! Normalized Sphericity 206 real Wet_OK ! Wet Metamorphism Switch 207 real OK__DE ! 208 real OK__wd ! New G*, from wet Dendritic 209 real G1__wd ! New G1, from wet Dendritic 210 real G2__wd ! New G2, from wet Dendritic 211 real OKlowT ! 212 real facVap ! 213 real OK_ldd ! 214 real G1_ldd ! 215 real G2_ldd ! 216 real DiamGx ! 217 real DiamOK ! 218 real No_Big ! 219 real dSPHER ! 220 real SPHER0 ! 221 real SPHbig ! 222 real G1_lds ! 223 real OK_mdT ! 224 real OKmidT ! 225 real OKhigT ! 226 real OK_mdd ! 227 real G1_mdd ! 228 real G2_mdd ! 229 real G1_mds ! 230 real OK_hdd ! 231 real G1_hdd ! 232 real G2_hdd ! 233 real OK_hds ! 234 real G1_hds ! 235 real T1__OK,T2__OK ! 236 real T3_xOK,T3__OK,T3_nOK ! 237 real ro1_OK,ro2_OK ! 238 real dT1_OK,dT2_OK,dT3xOK,dT3_OK ! 239 real dT4xOK,dT4_OK,dT4nOK,AngSno ! 240 real G2_hds,SphrOK,HISupd ! 241 real H1a_OK,H1b_OK,H1__OK ! 242 real H23aOK,H23bOK,H23_OK ! 243 real H2__OK,H3__OK ! 244 real H45_OK,H4__OK,H5__OK ! 245 real ViscSn,OK_Liq,OK_Ang,OKxLiq ! 246 real dSnMas,dzsnew,rosnew,rosmax,smb_old,smb_new 247 real zn_old,zn_new 248 249 real epsi5 ! Alpha ev67 single precision 250 real vdiam1 ! Small Grains Min.Diam.[.0001m] 251 real vdiam2 ! Spher.Variat.Max Diam. [mm] 252 real vdiam3 ! Min.Diam.|Limit Spher. [mm] 253 real vdiam4 ! Min.Diam.|Viscosity Change 254 real vsphe1 ! Max Sphericity 255 real vsphe2 ! Low T Metamorphism Coeff. 256 real vsphe3 ! Max.Sphericity (history=1) 257 real vsphe4 ! Min.Sphericity=>history=1 258 real vtang1,vtang2,vtang3,vtang4 ! Temperature Contribution 259 real vtang5,vtang6,vtang7,vtang8 ! 260 real vtang9,vtanga,vtangb,vtangc ! 261 real vrang1,vrang2 ! Density Contribution 262 real vgang1,vgang2,vgang3,vgang4 ! Grad(T) Contribution 263 real vgang5,vgang6,vgang7,vgang8 ! 264 real vgang9,vganga,vgangb,vgangc ! 265 real vgran6 ! Max.Sphericity for Settling 266 real vtelv1 ! Threshold | history = 2, 3 267 real vvap1 ! Vapor Pressure Coefficient 268 real vvap2 ! Vapor Pressure Exponent 269 real vgrat1 ! Boundary weak/mid grad(T) 270 real vgrat2 ! Boundary mid/strong grad(T) 271 real vfi ! PHI, strong grad(T) 272 real vvisc1,vvisc2,vvisc3,vvisc4 ! Viscosity Coefficients 273 real vvisc5,vvisc6,vvisc7 ! id., wet Snow 274 real rovisc ! Wet Snow Density Influence 275 real vdz3 ! Maximum Layer Densification 276 real OK__ws ! New G2 277 real G1__ws ! New G1, from wet Spheric 278 real G2__ws ! New G2, from wet Spheric 279 real husi_0,husi_1,husi_2,husi_3 ! Constants for New G2 280 real vtail1,vtail2 ! Constants for New G2 281 real frac_j ! Time Step [Day] 282 283 real vdent1 ! Wet Snow Metamorphism 284 integer nvdent1 ! (Coefficients for 285 integer nvdent2 ! Dendricity) 286 287 C +--Snow Properties: IO 288 C + ~~~~~~~~~~~~~~~~~~~ 289 ! #vp real G_curr(18),Gcases(18) 290 ! #vp common /GSnLOC/ Gcases 291 ! #wp real D__MAX 292 ! #wp common /GSnMAX/ D__MAX 293 294 295 C +--DATA 296 C + ==== 297 298 data vector/.true./ ! Vectorization Switch 299 data vdent1/ 0.5e8/ ! Wet Snow Metamorphism 300 cXF tuned for Greenland (2.e8=old value) 301 data nvdent1/ 3 / ! (Coefficients for 302 data nvdent2/16 / ! Dendricity) 303 304 data husi_0 /20. / ! 10 * 2 305 data husi_1 / 0.23873 / ! (3/4) /pi 306 data husi_2 / 4.18880 / ! (4/3) *pi 307 data husi_3 / 0.33333 / ! 1/3 308 data vtail1 / 1.28e-08/ ! Wet Metamorphism 309 data vtail2 / 4.22e-10/ ! (NON Dendritic / Spheric) 310 311 data epsi5 / 1.0e-5 / ! 312 313 data vdiam1 / 4.0 / ! Small Grains Min.Diameter 314 315 data vdiam2 / 0.5 / ! Spher.Variat.Max Diam.[mm] 316 data vdiam3 / 3.0 / ! Min.Diam.|Limit Spher.[mm] 317 data vdiam4 / 2.0 / ! Min.Diam.|Viscosity Change 318 319 data vsphe1 / 1.0 / ! Max Sphericity 320 data vsphe2 / 1.0e9 / ! Low T Metamorphism Coeff. 321 data vsphe3 / 0.5 / ! Max.Sphericity (history=1) 322 data vsphe4 / 0.1 / ! Min.Sphericity=>history=1 323 324 data vgran6 / 51. / ! Max.Sphericity for Settling 325 data vtelv1 / 5.e-1 / ! Threshold | history = 2, 3 326 327 data vvap1 /-6.e3 / ! Vapor Pressure Coefficient 328 data vvap2 / 0.4 / ! Vapor Pressure Exponent 329 330 data vgrat1 /0.05 / ! Boundary weak/mid grad(T) 331 data vgrat2 /0.15 / ! Boundary mid/strong grad(T) 332 data vfi /0.09 / ! PHI, strong grad(T) 333 334 data vvisc1 / 0.70 / ! Viscosity Coefficients 335 data vvisc2 / 1.11e5 / ! 336 data vvisc3 /23.00 / ! 337 data vvisc4 / 0.10 / ! 338 data vvisc5 / 1.00 / ! id., wet Snow 339 data vvisc6 / 2.00 / ! 340 data vvisc7 /10.00 / ! 341 data rovisc / 0.25 / ! Wet Snow Density Influence 342 data vdz3 / 0.30 / ! Maximum Layer Densification 343 344 345 C +--DATA (Coefficient Fonction fort Gradient Marbouty) 346 C + -------------------------------------------------- 347 348 data vtang1 /40.0/ ! Temperature Contribution 349 data vtang2 / 6.0/ ! 350 data vtang3 /22.0/ ! 351 data vtang4 / 0.7/ ! 352 data vtang5 / 0.3/ ! 353 data vtang6 / 6.0/ ! 354 data vtang7 / 1.0/ ! 355 data vtang8 / 0.8/ ! 356 data vtang9 /16.0/ ! 357 data vtanga / 0.2/ ! 358 data vtangb / 0.2/ ! 359 data vtangc /18.0/ ! 360 361 data vrang1 / 0.40/ ! Density Contribution 362 data vrang2 / 0.15/ ! 363 364 data vgang1 / 0.70/ ! Grad(T) Contribution 365 data vgang2 / 0.25/ ! 366 data vgang3 / 0.40/ ! 367 data vgang4 / 0.50/ ! 368 data vgang5 / 0.10/ ! 369 data vgang6 / 0.15/ ! 370 data vgang7 / 0.10/ ! 371 data vgang8 / 0.55/ ! 372 data vgang9 / 0.65/ ! 373 data vganga / 0.20/ ! 374 data vgangb / 0.85/ ! 375 data vgangc / 0.15/ ! 376 377 ! #wp data D__MAX / 4.00/ ! 378 379 380 C +-- 1. Metamorphoses dans les Strates 381 C + Metamorphism 382 C + ============================== 383 384 dt__SV2= dt__SV 385 frac_j = dt__SV2 / 86400. ! Time Step [Day] 386 387 zn4_SV = 0 388 389 390 C +-- 1.1 Initialisation: teneur en eau liquide et gradient de temperature 391 C + ------------------ liquid water content and temperature gradient 392 393 DO ikl=1,knonv 394 DO isn=1,isnoSV(ikl) 395 396 ro_dry(ikl,isn) = 1.e-3 *ro__SV(ikl,isn) ! Dry Density 397 . *(1. -eta_SV(ikl,isn)) ! [g/cm3] 398 etaSno(ikl,isn) = 1.e-1 *dzsnSV(ikl,isn) ! Liquid Water 399 . * ro__SV(ikl,isn) ! Content [g/cm2] 400 . * eta_SV(ikl,isn) ! 401 END DO 402 END DO 403 404 c!$OMP PARALLEL DO default(firstprivate) 405 c!$OMP.shared (/xSISVAT_I/,/xSISVAT_R/,/SoR0SV/,/SoI0SV/,/Sn_dSV/) 406 DO ikl=1,knonv 407 DO isn=1,isnoSV(ikl) 408 isnp = min(isn+1,isnoSV(ikl)) 409 410 dTsndz = abs( (TsisSV(ikl,isnp)-TsisSV(ikl,isn-1)) *2.e-2 411 . /max(((dzsnSV(ikl,isnp)+dzsnSV(ikl,isn) ) 412 . *( isnp - isn) 413 . +(dzsnSV(ikl,isn )+dzsnSV(ikl,isn-1))),epsi)) 414 C +... Factor 1.d-2 for Conversion K/m --> K/cm 415 416 417 C +-- 1.2 Metamorphose humide 418 C + Wet Snow Metamorphism 419 C + --------------------- 420 421 Wet_OK = max(zero,sign(unun,eta_SV(ikl,isn)-epsi)) 422 423 424 C +-- Vitesse de diminution de la dendricite 425 C + Rate of the dendricity decrease 426 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 427 sWater=1.d-1*ro__SV(ikl,isn)*eta_SV(ikl,isn) 428 . /max(epsi,ro_dry(ikl,isn)) 429 C +... sWater:Water Content [%] 430 C + 1.d-1= 1.d2(1->%) * 1.d-3(ro__SV*eta_SV:kg/m3->g/cm3) 431 432 exp1Wa= sWater**nvdent1 433 dDENDR=max(exp1Wa/nvdent2,vdent1*exp(vvap1/TfSnow)) 434 435 C +-- 1.2.1 Cas dendritique/dendritic Case 436 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 437 OK__wd=max(zero, ! 438 . sign(unun,-G1snSV(ikl,isn) ! 439 . -epsi )) ! 440 441 DENDRn=-G1snSV(ikl,isn)/G1_dSV ! Normalized Dendricity (+) 442 SPHERn= G2snSV(ikl,isn)/G1_dSV ! Normalized Sphericity 443 DENDRn= DENDRn -dDENDR *frac_j ! New Dendricity (+) 444 SPHERn= SPHERn +dDENDR *frac_j ! New Sphericity 445 446 OK__DE=max(zero, ! IF 1., 447 . sign(unun, DENDRn ! NO change 448 . -epsi )) ! Dendr. -> Spheric 449 450 G1__wd=OK__DE * ( -DENDRn*G1_dSV) ! Dendritic 451 . +(1.-OK__DE)* min(G1_dSV,SPHERn*G1_dSV) ! Dendr. -> Spheric 452 G2__wd=OK__DE * min(G1_dSV,SPHERn*G1_dSV) ! Spheric 453 . +(1.-OK__DE)*(ADSdSV-min(SPHERn,vsphe1)) ! Spher. -> Size 454 455 C +-- 1.2.2 Cas non dendritique non completement spherique 456 C + Evolution de la Sphericite seulement. 457 C + Non dendritic and not completely spheric Case 458 C + Evolution of Sphericity only (not size) 459 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 460 OK__ws=max(zero, ! 461 . sign(unun, G1_dSV ! 462 . -epsi5 ! 463 . -G1snSV(ikl,isn))) ! 464 465 SPHERn= G1snSV(ikl,isn)/G1_dSV 466 SPHERn= SPHERn +dDENDR *frac_j 467 G1__ws= min(G1_dSV,SPHERn*G1_dSV) 468 469 C +-- 1.2.3 Cas non dendritique et spherique / non dendritic and spheric 470 C + Evolution de la Taille seulement / Evolution of Size only 471 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 472 G2__ws = husi_0 473 . *( husi_1 474 . *(husi_2 *( G2snSV(ikl,isn)/husi_0)**3 475 . +(vtail1 +vtail2 *exp1Wa )*dt__SV2)) 476 . ** husi_3 477 478 479 C +-- 1.3 Metamorposes seches / Dry Metamorphism 480 C + -------------------------------------- 481 482 483 C +-- 1.3.1 Calcul Metamorphose faible/low Gradient (0.00-0.05 deg/cm) 484 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 485 OKlowT=max(zero, ! 486 . sign(unun, vgrat1 ! 487 . -dTsndz )) ! 488 489 facVap=exp(vvap1/TsisSV(ikl,isn)) 490 491 C +-- 1.3.1.1 Cas dendritique / dendritic Case 492 493 OK_ldd=max(zero, ! 494 . sign(unun,-G1snSV(ikl,isn) ! 495 . -epsi )) ! 496 497 DENDRn=-G1snSV(ikl,isn) /G1_dSV 498 SPHERn= G2snSV(ikl,isn) /G1_dSV 499 DENDRn= DENDRn-vdent1*facVap*frac_j 500 SPHERn= SPHERn+vsphe2*facVap*frac_j 501 502 OK__DE=max(zero, ! IF 1., 503 . sign(unun, DENDRn ! NO change 504 . -epsi )) ! Dendr. -> Spheric 505 506 G1_ldd= OK__DE * ( -DENDRn*G1_dSV) ! Dendritic 507 . +(1.-OK__DE)* min(G1_dSV,SPHERn*G1_dSV) ! Dendr. -> Spheric 508 G2_ldd= OK__DE * min(G1_dSV,SPHERn*G1_dSV) ! Spheric 509 . +(1.-OK__DE)*(ADSdSV-min(SPHERn,vsphe1)) ! Spher. -> Size 510 511 C +-- 1.3.1.2 Cas non dendritique / non dendritic Case 512 513 SPHERn=G1snSV(ikl,isn)/G1_dSV 514 DiamGx=G2snSV(ikl,isn)*0.1 515 516 istoOK=min( abs(istoSV(ikl,isn)- 517 . istdSV(1) ),1) ! zero if istoSV = 1 518 DiamOK=max(zero, sign(unun,vdiam2-DiamGx)) 519 No_Big= istoOK+DiamOK 520 No_Big=min(No_Big,unun) 521 522 dSPHER= vsphe2*facVap*frac_j ! 523 SPHER0= SPHERn+dSPHER ! small grains 524 SPHbig= SPHERn+dSPHER ! big grains 525 . *exp(min(zero,vdiam3-G2snSV(ikl,isn))) ! (history = 2 or 3) 526 SPHbig= min(vsphe3,SPHbig) ! limited sphericity 527 SPHERn= No_Big * SPHER0 528 . + (1.-No_Big)* SPHbig 529 530 G1_lds= min(G1_dSV,SPHERn*G1_dSV) 531 532 C +-- 1.3.2 Calcul Metamorphose Gradient Moyen/Moderate (0.05-0.15) 533 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 534 OK_mdT=max(zero, ! 535 . sign(unun, vgrat2 ! 536 . -dTsndz)) ! 537 OKmidT= OK_mdT *(1.-OKlowT) ! 538 OKhigT= (1. -OK_mdT) *(1.-OKlowT) ! 539 540 facVap=vdent1*exp(vvap1/TsisSV(ikl,isn)) 541 . * (1.e2 *dTsndz)**vvap2 542 543 C +-- 1.3.2.1 cas dendritique / dendritic case. 544 545 OK_mdd=max(zero, ! 546 . sign(unun,-G1snSV(ikl,isn) ! 547 . -epsi )) ! 548 549 DENDRn=-G1snSV(ikl,isn)/G1_dSV 550 SPHERn= G2snSV(ikl,isn)/G1_dSV 551 DENDRn= DENDRn - facVap*frac_j 552 SPHERn= SPHERn - facVap*frac_j 553 554 OK__DE=max(zero, ! IF 1., 555 . sign(unun, DENDRn ! NO change 556 . -epsi )) ! Dendr. -> Spheric 557 558 G1_mdd= OK__DE * ( -DENDRn*G1_dSV) ! Dendritic 559 . +(1.-OK__DE)* max(zero ,SPHERn*G1_dSV) ! Dendr. -> Spheric 560 G2_mdd= OK__DE * max(zero ,SPHERn*G1_dSV) ! Spheric 561 . +(1.-OK__DE)*(ADSdSV-max(SPHERn,zero )) ! Spher. -> Size 562 563 C +-- 1.3.2.2 Cas non dendritique / non dendritic Case 564 565 SPHERn=G1snSV(ikl,isn)/G1_dSV 566 SPHERn= SPHERn-facVap*frac_j 567 G1_mds=max(zero,SPHERn*G1_dSV) 568 569 C +-- 1.3.3 Calcul Metamorphose fort / high Gradient 570 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 571 facVap=vdent1*exp(vvap1/TsisSV(ikl,isn)) 572 . * (1.e2 *dTsndz)**vvap2 573 574 C +-- 1.3.3.1 Cas dendritique / dendritic Case 575 576 OK_hdd=max(zero, ! 577 . sign(unun,-G1snSV(ikl,isn) ! 578 . -epsi )) ! 579 580 DENDRn=-G1snSV(ikl,isn)/G1_dSV ! 581 SPHERn= G2snSV(ikl,isn)/G1_dSV ! 582 DENDRn= DENDRn - facVap*frac_j ! 583 SPHERn= SPHERn - facVap*frac_j ! Non dendritic 584 C + ! and angular 585 OK__DE=max(zero, ! IF 1., 586 . sign(unun, DENDRn ! NO change 587 . -epsi )) ! Dendr. -> Spheric 588 589 G1_hdd= OK__DE * ( -DENDRn*G1_dSV) ! Dendritic 590 . +(1.-OK__DE)* max(zero ,SPHERn*G1_dSV) ! Dendr. -> Spheric 591 G2_hdd= OK__DE * max(zero ,SPHERn*G1_dSV) ! Spheric 592 . +(1.-OK__DE)*(ADSdSV-max(SPHERn,zero )) ! Spher. -> Size 593 594 C +-- 1.3.3.2 Cas non dendritique non completement anguleux. 595 C + non dendritic and spericity gt. 0 596 597 OK_hds=max(zero, ! 598 . sign(unun, G1snSV(ikl,isn) ! 599 . -epsi )) ! 600 601 SPHERn= G1snSV(ikl,isn)/G1_dSV 602 SPHERn= SPHERn - facVap*frac_j 603 G1_hds= max(zero,SPHERn*G1_dSV) 604 605 C +-- 1.3.3.3 Cas non dendritique et anguleux 606 C + dendritic and spericity = 0. 607 608 T1__OK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang1)) 609 T2__OK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang2)) 610 T3_xOK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang3)) 611 T3__OK = T3_xOK * (1. - T2__OK) 612 T3_nOK = (1. - T3_xOK) * (1. - T2__OK) 613 ro1_OK = max(zero,sign(unun,vrang1-ro_dry(ikl,isn))) 614 ro2_OK = max(zero,sign(unun,ro_dry(ikl,isn)-vrang2)) 615 dT1_OK = max(zero,sign(unun,vgang1-dTsndz )) 616 dT2_OK = max(zero,sign(unun,vgang2-dTsndz )) 617 dT3xOK = max(zero,sign(unun,vgang3-dTsndz )) 618 dT3_OK = dT3xOK * (1. - dT2_OK) 619 dT4xOK = max(zero,sign(unun,vgang4-dTsndz )) 620 dT4_OK = dT4xOK * (1. - dT3_OK) 621 . * (1. - dT2_OK) 622 dT4nOK = (1. - dT4xOK) * (1. - dT3_OK) 623 . * (1. - dT2_OK) 624 625 C +-- Influence de la Temperature /Temperature Influence 626 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 627 AngSno = 628 . T1__OK ! 11 629 . *(T2__OK*(vtang4+vtang5*(TfSnow -TsisSV(ikl,isn)) ! 12 630 . /vtang6) ! 631 . +T3__OK*(vtang7-vtang8*(TfSnow-vtang2-TsisSV(ikl,isn)) ! 13 632 . /vtang9) ! 633 . +T3_nOK*(vtanga-vtangb*(TfSnow-vtang3-TsisSV(ikl,isn)) ! 14 634 . /vtangc)) ! 635 636 C +-- Influence de la Masse Volumique /Density Influence 637 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 638 . * ro1_OK 639 . *( ro2_OK*(1. - (ro_dry(ikl,isn)-vrang2) ! 640 . /(vrang1-vrang2)) ! 641 . +1.-ro2_OK ) ! 642 643 C +-- Influence du Gradient de Temperature /Temperature Gradient Influence 644 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 645 . *( dT1_OK*(dT2_OK*vgang5*(dTsndz-vgang6) ! 15 646 . /(vgang2-vgang6) ! 647 . +dT3_OK*vgang7 ! 16 648 . +dT4_OK*vgang9 ! 17 649 . +dT4nOK*vgangb ) ! 18 650 . +1.-dT1_OK ) ! 651 . + ro1_OK 652 . * dT1_OK*(dT3_OK*vgang8*(dTsndz-vgang2) 653 . /(vgang3-vgang2) 654 . +dT4_OK*vganga*(dTsndz-vgang3) 655 . /(vgang4-vgang3) 656 . +dT4nOK*vgangc*(dTsndz-vgang4) 657 . /(vgang1-vgang4)) 658 659 G2_hds = G2snSV(ikl,isn) + 1.d2 *AngSno*vfi *frac_j 660 661 662 C +--New Properties 663 C + -------------- 664 665 G1_bak = G1snSV(ikl,isn) 666 G2_bak = G2snSV(ikl,isn) 667 668 G1snSV(ikl,isn) = Wet_OK * ( OK__wd *G1__wd ! 1 669 . +(1.-OK__wd)* OK__ws *G1__ws ! 2 670 . +(1.-OK__wd)*(1.-OK__ws)*G1_bak) ! 3 671 . +(1. - Wet_OK) ! 672 . *( OKlowT *( OK_ldd *G1_ldd ! 4 673 . +(1.-OK_ldd) *G1_lds) ! 5 674 . + OKmidT *( OK_mdd *G1_mdd ! 6 675 . +(1.-OK_mdd) *G1_mds) ! 7 676 . + OKhigT *( OK_hdd *G1_hdd ! 8 677 . +(1.-OK_hdd)* OK_hds *G1_hds ! 9 678 . +(1.-OK_hdd)*(1.-OK_hds)*G1_bak)) ! 10 679 680 cXF 681 if(G1snSV(ikl,isn)<0.1) 682 . G2_hds = G2snSV(ikl,isn) + 1.d1 *AngSno*vfi *frac_j 683 cXF 684 685 686 G2snSV(ikl,isn) = Wet_OK * ( OK__wd *G2__wd ! 1 687 . +(1.-OK__wd)* OK__ws *G2_bak ! 2 688 . +(1.-OK__wd)*(1.-OK__ws)*G2__ws) ! 3 689 . +(1. - Wet_OK) ! 690 . *( OKlowT *( OK_ldd *G2_ldd ! 4 691 . +(1.-OK_ldd) *G2_bak) ! 5 692 . + OKmidT *( OK_mdd *G2_mdd ! 6 693 . +(1.-OK_mdd) *G2_bak) ! 7 694 . + OKhigT *( OK_hdd *G2_hdd ! 8 695 . +(1.-OK_hdd)* OK_hds *G2_bak ! 9 696 . +(1.-OK_hdd)*(1.-OK_hds)*G2_hds)) ! 10 697 698 C +--Snow Properties: IO Set Up 699 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~ 700 ! #vp G_curr( 1) = Wet_OK * OK__wd 701 ! #vp G_curr( 2) = Wet_OK *(1.-OK__wd)* OK__ws 702 ! #vp G_curr( 3) = Wet_OK *(1.-OK__wd)*(1.-OK__ws) 703 ! #vp G_curr( 4) = (1.-Wet_OK)* OKlowT * OK_ldd 704 ! #vp G_curr( 5) = (1.-Wet_OK)* OKlowT *(1.-OK_ldd) 705 ! #vp G_curr( 6) = (1.-Wet_OK)* OKmidT * OK_mdd 706 ! #vp G_curr( 7) = (1.-Wet_OK)* OKmidT *(1.-OK_mdd) 707 ! #vp G_curr( 8) = (1.-Wet_OK)* OKhigT * OK_hdd 708 ! #vp G_curr( 9) = (1.-Wet_OK)* OKhigT *(1.-OK_hdd)* OK_hds 709 ! #vp G_curr(10) = (1.-Wet_OK)* OKhigT *(1.-OK_hdd)*(1.-OK_hds) 710 ! #vp G_curr(11) = T1__OK * G_curr(10) 711 ! #vp G_curr(12) = T2__OK * G_curr(10) 712 ! #vp G_curr(13) = T3__OK * G_curr(10) 713 ! #vp G_curr(14) = T3_nOK * G_curr(10) 714 ! #vp G_curr(15) = ro1_OK* dT1_OK * dT2_OK * G_curr(10) 715 ! #vp G_curr(16) = ro1_OK* dT1_OK * dT3_OK * G_curr(10) 716 ! #vp G_curr(17) = ro1_OK* dT1_OK * dT4_OK * G_curr(10) 717 ! #vp G_curr(18) = ro1_OK* dT1_OK * dT4nOK * G_curr(10) 718 719 ! #vp Gcases( 1) = max(Gcases( 1),G_curr( 1)) 720 ! #vp Gcases( 2) = max(Gcases( 2),G_curr( 2)) 721 ! #vp Gcases( 3) = max(Gcases( 3),G_curr( 3)) 722 ! #vp Gcases( 4) = max(Gcases( 4),G_curr( 4)) 723 ! #vp Gcases( 5) = max(Gcases( 5),G_curr( 5)) 724 ! #vp Gcases( 6) = max(Gcases( 6),G_curr( 6)) 725 ! #vp Gcases( 7) = max(Gcases( 7),G_curr( 7)) 726 ! #vp Gcases( 8) = max(Gcases( 8),G_curr( 8)) 727 ! #vp Gcases( 9) = max(Gcases( 9),G_curr( 9)) 728 ! #vp Gcases(10) = max(Gcases(10),G_curr(10)) 729 ! #vp Gcases(11) = max(Gcases(11),G_curr(11)) 730 ! #vp Gcases(12) = max(Gcases(12),G_curr(12)) 731 ! #vp Gcases(13) = max(Gcases(13),G_curr(13)) 732 ! #vp Gcases(14) = max(Gcases(14),G_curr(14)) 733 ! #vp Gcases(15) = max(Gcases(15),G_curr(15)) 734 ! #vp Gcases(16) = max(Gcases(16),G_curr(16)) 735 ! #vp Gcases(17) = max(Gcases(17),G_curr(17)) 736 ! #vp Gcases(18) = max(Gcases(18),G_curr(18)) 737 738 C +--Snow Properties: IO 739 C + ~~~~~~~~~~~~~~~~~~~ 740 ! #vp IF (isn .le. isnoSV(ikl)) 741 ! #vp. write(47,471)isn ,isnoSV(ikl) , 742 ! #vp. TsisSV(ikl,isn),ro__SV(ikl,isn),eta_SV(ikl,isn), 743 ! #vp. G1_bak ,G2_bak ,istoSV(ikl,isn), 744 ! #vp. dTsndz, 745 ! #vp. ( k ,k=1,18), 746 ! #vp. (G_curr(k),k=1,18), 747 ! #vp. (Gcases(k),k=1,18), 748 ! #vp. Wet_OK,OK__wd,G1__wd,G2__wd, 749 ! #vp. 1.-OK__wd,OK__ws,G1__ws,1.-OK__ws,G2__ws, 750 ! #vp. 1.-Wet_OK,OKlowT,OK_ldd,G1_ldd, G2_ldd, 751 ! #vp. 1.-OK_ldd,G1_lds, 752 ! #vp. OKmidT,OK_mdd,G1_mdd, G1_mdd, 753 ! #vp. 1.-OK_mdd,G1_mds, 754 ! #vp. OKhigT,OK_hdd,G1_hdd, G2_hdd, 755 ! #vp. 1.-OK_hdd,OK_hds, G1_hds, 756 ! #vp. 1.-OK_hds,G2_hds, 757 ! #vp. G1snSV(ikl,isn), 758 ! #vp. G2snSV(ikl,isn) 759 760 END DO 761 END DO 762 c!$OMP END PARALLEL DO 763 764 C +-- 2. Mise a Jour Variables Historiques (Cas non dendritique) 765 C + Update of the historical Variables 766 C + ======================================================= 767 768 IF (vector) THEN 769 cXF 770 DO ikl=1,knonv 771 DO isn=1,isnoSV(ikl) 772 SphrOK = max(zero,sign(unun, G1snSV(ikl,isn))) 773 H1a_OK = max(zero,sign(unun,vsphe4-G1snSV(ikl,isn))) 774 H1b_OK = 1 - min(1 , istoSV(ikl,isn)) 775 H1__OK = H1a_OK*H1b_OK 776 H23aOK = max(zero,sign(unun,vsphe4-G1_dSV 777 . +G1snSV(ikl,isn))) 778 H23bOK = max(zero,sign(unun,etaSno(ikl,isn) 779 . /max(epsi,dzsnSV(ikl,isn)) 780 . -vtelv1 )) 781 H23_OK = H23aOK*H23bOK 782 H2__OK = 1 - min(1 , istoSV(ikl,isn)) 783 H3__OK = 1 - min(1 , abs(istoSV(ikl,isn)-istdSV(1))) 784 H45_OK = max(zero,sign(unun,TfSnow-TsisSV(ikl,isn)+epsi)) 785 H4__OK = 1 - min(1 , abs(istoSV(ikl,isn)-istdSV(2))) 786 H5__OK = 1 - min(1 , abs(istoSV(ikl,isn)-istdSV(3))) 787 788 HISupd = 789 . SphrOK*(H1__OK *istdSV(1) 790 . +(1.-H1__OK)* H23_OK *(H2__OK*istdSV(2) 791 . +H3__OK*istdSV(3)) 792 . +(1.-H1__OK)*(1.-H23_OK) *H45_OK*(H4__OK*istdSV(4) 793 . +H5__OK*istdSV(5))) 794 istoSV(ikl,isn) = HISupd + 795 . (1.-min(unun,HISupd)) *istoSV(ikl,isn) 796 END DO 797 END DO 798 ELSE 799 800 801 C +-- 2. Mise a Jour Variables Historiques (Cas non dendritique) 802 C + Update of the historical Variables 803 C + ======================================================= 804 805 DO ikl=1,knonv 806 DO isn=iiceSV(ikl),isnoSV(ikl) 807 IF (G1snSV(ikl,isn).ge.0.) THEN 808 IF(G1snSV(ikl,isn).lt.vsphe4.and.istoSV(ikl,isn).eq.0) THEN 809 istoSV(ikl,isn)=istdSV(1) 810 ELSEIF(G1_dSV-G1snSV(ikl,isn) .lt.vsphe4.and. 811 . etaSno(ikl,isn)/dzsnSV(ikl,isn).gt.vtelv1) THEN 812 IF (istoSV(ikl,isn).eq.0) 813 . istoSV(ikl,isn)= istdSV(2) 814 IF (istoSV(ikl,isn).eq.istdSV(1)) 815 . istoSV(ikl,isn)= istdSV(3) 816 ELSEIF(TsisSV(ikl,isn).lt.TfSnow) THEN 817 IF (istoSV(ikl,isn).eq.istdSV(2)) 818 . istoSV(ikl,isn)= istdSV(4) 819 IF (istoSV(ikl,isn).eq.istdSV(3)) 820 . istoSV(ikl,isn)= istdSV(5) 821 END IF 822 END IF 823 END DO 824 END DO 1 2 subroutine SISVAT_GSn 3 4 ! +------------------------------------------------------------------------+ 5 ! | MAR SISVAT_GSn 20-09-2003 MAR | 6 ! | SubRoutine SISVAT_GSn simulates SNOW Metamorphism | 7 ! +------------------------------------------------------------------------+ 8 ! | | 9 ! | PARAMETERS: knonv: Total Number of columns = | 10 ! | ^^^^^^^^^^ = Total Number of continental grid boxes | 11 ! | X Number of Mosaic Cell per grid box | 12 ! | | 13 ! | INPUT / isnoSV = total Nb of Ice/Snow Layers | 14 ! | OUTPUT: iiceSV = total Nb of Ice Layers | 15 ! | ^^^^^^ istoSV = 0,...,5 : Snow History (see istdSV data) | 16 ! | | 17 ! | INPUT: TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 18 ! | ^^^^^ & Snow Temperatures (layers 1,2,...,nsno) [K] | 19 ! | ro__SV : Soil/Snow Volumic Mass [kg/m3] | 20 ! | eta_SV : Soil/Snow Water Content [m3/m3] | 21 ! | slopSV : Surface Slope [-] | 22 ! | dzsnSV : Snow Layer Thickness [m] | 23 ! | dt__SV2 : Time Step [s] | 24 ! | | 25 ! | INPUT / G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer | 26 ! | OUTPUT: G2snSV : Sphericity (>0) or Size of Snow Layer | 27 ! | ^^^^^^ | 28 ! | | 29 ! | Formalisme adopte pour la Representation des Grains: | 30 ! | Formalism for the Representation of Grains: | 31 ! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | 32 ! | | 33 ! | 1 - -1 Neige Fraiche | 34 ! | / \ | ------------- | 35 ! | / \ | Dendricite decrite par Dendricite | 36 ! | / \ | Dendricity et Sphericite | 37 ! | / \ | | 38 ! | 2---------3 - 0 described by Dendricity | 39 ! | and Sphericity | 40 ! | |---------| | 41 ! | 0 1 | 42 ! | Sphericite | 43 ! | Sphericity | 44 ! | | 45 ! | 4---------5 - | 46 ! | | | | | 47 ! | | | | Diametre (1/10eme de mm) (ou Taille) | 48 ! | | | | Diameter (1/10th of mm) (or Size ) | 49 ! | | | | | 50 ! | | | | Neige non dendritique | 51 ! | 6---------7 - --------------------- | 52 ! | decrite par Sphericite | 53 ! | et Taille | 54 ! | described by Sphericity | 55 ! | and Size | 56 ! | | 57 ! | Les Variables du Modele: | 58 ! | Model Variables: | 59 ! | ^^^^^^^^^^^^^^^^^^^^^^^^ | 60 ! | Cas Dendritique Cas non Dendritique | 61 ! | | 62 ! | G1snSV : Dendricite G1snSV : Sphericite | 63 ! | G2snSV : Sphericite G2snSV : Taille (1/10e mm) | 64 ! | Size | 65 ! | | 66 ! | Cas Dendritique/ Dendritic Case | 67 ! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | 68 ! | Dendricite(Dendricity) G1snSV | 69 ! | varie de -G1_dSV (-99 par defaut / etoile) a 0 | 70 ! | division par -G1_dSV pour obtenir des valeurs entre 1 et 0 | 71 ! | varies from -G1_dSV (default -99 / fresh snow) to 0 | 72 ! | division by -G1_dSV to obtain values between 1 and 0 | 73 ! | | 74 ! | Sphericite(Sphericity) G2snSV | 75 ! | varie de 0 (cas completement anguleux) | 76 ! | a G1_dSV (99 par defaut, cas spherique) | 77 ! | division par G1_dSV pour obtenir des valeurs entre 0 et 1 | 78 ! | varies from 0 (full faceted) to G1_dSV | 79 ! | | 80 ! | Cas non Dendritique / non Dendritic Case | 81 ! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | 82 ! | Sphericite(Sphericity) G1snSV | 83 ! | varie de 0 (cas completement anguleux) | 84 ! | a G1_dSV (99 par defaut, cas spherique) | 85 ! | division par G1_dSV pour obtenir des valeurs entre 0 et 1 | 86 ! | varies from 0 (full faceted) to G1_dSV | 87 ! | | 88 ! | Taille (Size) G2snSV | 89 ! | superieure a ADSdSV (.4 mm) et ne fait que croitre | 90 ! | greater than ADSdSV (.4 mm) always increases | 91 ! | | 92 ! | Exemples: Points caracteristiques des Figures ci-dessus | 93 ! | ^^^^^^^^^ | 94 ! | | 95 ! | G1snSV G2snSV dendricite sphericite taille | 96 ! | dendricity sphericity size | 97 ! | ------------------------------------------------------------------ | 98 ! | [1/10 mm] | 99 ! | 1 -G1_dSV sph3SN 1 0.5 | 100 ! | 2 0 0 0 0 | 101 ! | 3 0 G1_dSV 0 1 | 102 ! | 4 0 ADSdSV 0 4. | 103 ! | 5 G1_dSV ADSdSV-vsphe1 1 3. | 104 ! | 6 0 -- 0 -- | 105 ! | 7 G1_dSV -- 1 -- | 106 ! | | 107 ! | par defaut: G1_dSV=99. | 108 ! | sph3SN=50. | 109 ! | ADSdSV= 4. | 110 ! | vsphe1=1. | 111 ! | | 112 ! | Methode: | 113 ! | ^^^^^^^^ | 114 ! | 1. Evolution Types de Grains selon Lois de Brun et al. (1992): | 115 ! | Grain metamorphism according to Brun et al. (1992): | 116 ! | Plusieurs Cas sont a distiguer / the different Cases are: | 117 ! | 1.1 Metamorphose Neige humide / wet Snow | 118 ! | 1.2 Metamorphose Neige seche / dry Snow | 119 ! | 1.2.1 Gradient faible / low Temperature Gradient | 120 ! | 1.2.2 Gradient moyen / moderate Temperature Gradient | 121 ! | 1.2.3 Gradient fort / high Temperature Gradient | 122 ! | Dans chaque Cas on separe Neige Dendritique et non Dendritique | 123 ! | le Passage Dendritique -> non Dendritique | 124 ! | se fait lorsque G1snSV devient > 0 | 125 ! | the Case of Dentritic or non Dendritic Snow is treated separately | 126 ! | the Limit Dentritic -> non Dendritic is reached when G1snSV > 0 | 127 ! | | 128 ! | 2. Tassement: Loi de Viscosite adaptee selon le Type de Grains | 129 ! | Snow Settling: Viscosity depends on the Grain Type | 130 ! | | 131 ! | 3. Update Variables historiques (cas non dendritique seulement) | 132 ! | nhSNow defaut | 133 ! | 0 Cas normal | 134 ! | istdSV(1) 1 Grains anguleux / faceted cristal | 135 ! | istdSV(2) 2 Grains ayant ete en presence d eau liquide | 136 ! | mais n'ayant pas eu de caractere anguleux / | 137 ! | liquid water and no faceted cristals before | 138 ! | istdSV(3) 3 Grains ayant ete en presence d eau liquide | 139 ! | ayant eu auparavant un caractere anguleux / | 140 ! | liquid water and faceted cristals before | 141 ! | | 142 ! | REFER. : Brun et al. 1989, J. Glaciol 35 pp. 333--342 | 143 ! | ^^^^^^^^ Brun et al. 1992, J. Glaciol 38 pp. 13-- 22 | 144 ! | (CROCUS Model, adapted to MAR at CEN by H.Gallee) | 145 ! | | 146 ! | REFER. : Marbouty, D. 1980, J. Glaciol 26 pp. xxx--xxx | 147 ! | ^^^^^^^^ (CROCUS Model, adapted to MAR at CEN by H.Gallee) | 148 ! | (for angular shapes) | 149 ! | | 150 ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) | 151 ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ | 152 ! | FILE | CONTENT | 153 ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ | 154 ! | # SISVAT_GSn.vp | #vp: OUTPUT/Verification: Snow Properties | 155 ! | | unit 47, SubRoutines SISVAT_zSn, _GSn | 156 ! | # stdout | #wp: OUTPUT/Verification: Snow Properties | 157 ! | | unit 6, SubRoutine SISVAT_GSn | 158 ! | | 159 ! +------------------------------------------------------------------------+ 160 161 162 163 164 ! +--Global Variables 165 ! + ================ 166 167 use VARphy 168 use VAR_SV 169 use VARdSV 170 use VAR0SV 171 use VARxSV 172 use VARtSV 173 174 175 IMPLICIT NONE 176 177 178 179 ! +--INPUT/OUTPUT 180 ! + ------------ 181 182 183 ! +--OUTPUT 184 ! + ------ 185 186 integer :: dt__SV2 187 188 189 ! +--Local Variables 190 ! + ================ 191 192 logical :: vector ! 193 integer :: ikl ! 194 integer :: isn ,isnp ! 195 integer :: istoOK ! 196 real :: G1_bak,G2_bak ! Old Values of G1, G2 197 real :: ro_dry(knonv, nsno) ! Dry Density [g/cm3] 198 real :: etaSno(knonv, nsno) ! Liquid Water Content [g/cm2] 199 real :: SnMass(knonv) ! Snow Mass [kg/m2] 200 real :: dTsndz ! Temperature Gradient 201 real :: sWater ! Water Content [%] 202 real :: exp1Wa ! 203 real :: dDENDR ! Dendricity Increment 204 real :: DENDRn ! Normalized Dendricity 205 real :: SPHERn ! Normalized Sphericity 206 real :: Wet_OK ! Wet Metamorphism Switch 207 real :: OK__DE ! 208 real :: OK__wd ! New G*, from wet Dendritic 209 real :: G1__wd ! New G1, from wet Dendritic 210 real :: G2__wd ! New G2, from wet Dendritic 211 real :: OKlowT ! 212 real :: facVap ! 213 real :: OK_ldd ! 214 real :: G1_ldd ! 215 real :: G2_ldd ! 216 real :: DiamGx ! 217 real :: DiamOK ! 218 real :: No_Big ! 219 real :: dSPHER ! 220 real :: SPHER0 ! 221 real :: SPHbig ! 222 real :: G1_lds ! 223 real :: OK_mdT ! 224 real :: OKmidT ! 225 real :: OKhigT ! 226 real :: OK_mdd ! 227 real :: G1_mdd ! 228 real :: G2_mdd ! 229 real :: G1_mds ! 230 real :: OK_hdd ! 231 real :: G1_hdd ! 232 real :: G2_hdd ! 233 real :: OK_hds ! 234 real :: G1_hds ! 235 real :: T1__OK,T2__OK ! 236 real :: T3_xOK,T3__OK,T3_nOK ! 237 real :: ro1_OK,ro2_OK ! 238 real :: dT1_OK,dT2_OK,dT3xOK,dT3_OK ! 239 real :: dT4xOK,dT4_OK,dT4nOK,AngSno ! 240 real :: G2_hds,SphrOK,HISupd ! 241 real :: H1a_OK,H1b_OK,H1__OK ! 242 real :: H23aOK,H23bOK,H23_OK ! 243 real :: H2__OK,H3__OK ! 244 real :: H45_OK,H4__OK,H5__OK ! 245 real :: ViscSn,OK_Liq,OK_Ang,OKxLiq ! 246 real :: dSnMas,dzsnew,rosnew,rosmax,smb_old,smb_new 247 real :: zn_old,zn_new 248 249 real :: epsi5 ! Alpha ev67 single precision 250 real :: vdiam1 ! Small Grains Min.Diam.[.0001m] 251 real :: vdiam2 ! Spher.Variat.Max Diam. [mm] 252 real :: vdiam3 ! Min.Diam.|Limit Spher. [mm] 253 real :: vdiam4 ! Min.Diam.|Viscosity Change 254 real :: vsphe1 ! Max Sphericity 255 real :: vsphe2 ! Low T Metamorphism Coeff. 256 real :: vsphe3 ! Max.Sphericity (history=1) 257 real :: vsphe4 ! Min.Sphericity=>history=1 258 real :: vtang1,vtang2,vtang3,vtang4 ! Temperature Contribution 259 real :: vtang5,vtang6,vtang7,vtang8 ! 260 real :: vtang9,vtanga,vtangb,vtangc ! 261 real :: vrang1,vrang2 ! Density Contribution 262 real :: vgang1,vgang2,vgang3,vgang4 ! Grad(T) Contribution 263 real :: vgang5,vgang6,vgang7,vgang8 ! 264 real :: vgang9,vganga,vgangb,vgangc ! 265 real :: vgran6 ! Max.Sphericity for Settling 266 real :: vtelv1 ! Threshold | history = 2, 3 267 real :: vvap1 ! Vapor Pressure Coefficient 268 real :: vvap2 ! Vapor Pressure Exponent 269 real :: vgrat1 ! Boundary weak/mid grad(T) 270 real :: vgrat2 ! Boundary mid/strong grad(T) 271 real :: vfi ! PHI, strong grad(T) 272 real :: vvisc1,vvisc2,vvisc3,vvisc4 ! Viscosity Coefficients 273 real :: vvisc5,vvisc6,vvisc7 ! id., wet Snow 274 real :: rovisc ! Wet Snow Density Influence 275 real :: vdz3 ! Maximum Layer Densification 276 real :: OK__ws ! New G2 277 real :: G1__ws ! New G1, from wet Spheric 278 real :: G2__ws ! New G2, from wet Spheric 279 real :: husi_0,husi_1,husi_2,husi_3 ! Constants for New G2 280 real :: vtail1,vtail2 ! Constants for New G2 281 real :: frac_j ! Time Step [Day] 282 283 real :: vdent1 ! Wet Snow Metamorphism 284 integer :: nvdent1 ! (Coefficients for 285 integer :: nvdent2 ! Dendricity) 286 287 ! +--Snow Properties: IO 288 ! + ~~~~~~~~~~~~~~~~~~~ 289 ! #vp real G_curr(18),Gcases(18) 290 ! #vp common /GSnLOC/ Gcases 291 ! #wp real D__MAX 292 ! #wp common /GSnMAX/ D__MAX 293 294 295 ! +--DATA 296 ! + ==== 297 298 data vector/.true./ ! Vectorization Switch 299 data vdent1/ 0.5e8/ ! Wet Snow Metamorphism 300 !XF tuned for Greenland (2.e8=old value) 301 data nvdent1/ 3 / ! (Coefficients for 302 data nvdent2/16 / ! Dendricity) 303 304 data husi_0 /20. / ! 10 * 2 305 data husi_1 / 0.23873 / ! (3/4) /pi 306 data husi_2 / 4.18880 / ! (4/3) *pi 307 data husi_3 / 0.33333 / ! 1/3 308 data vtail1 / 1.28e-08/ ! Wet Metamorphism 309 data vtail2 / 4.22e-10/ ! (NON Dendritic / Spheric) 310 311 data epsi5 / 1.0e-5 / ! 312 313 data vdiam1 / 4.0 / ! Small Grains Min.Diameter 314 315 data vdiam2 / 0.5 / ! Spher.Variat.Max Diam.[mm] 316 data vdiam3 / 3.0 / ! Min.Diam.|Limit Spher.[mm] 317 data vdiam4 / 2.0 / ! Min.Diam.|Viscosity Change 318 319 data vsphe1 / 1.0 / ! Max Sphericity 320 data vsphe2 / 1.0e9 / ! Low T Metamorphism Coeff. 321 data vsphe3 / 0.5 / ! Max.Sphericity (history=1) 322 data vsphe4 / 0.1 / ! Min.Sphericity=>history=1 323 324 data vgran6 / 51. / ! Max.Sphericity for Settling 325 data vtelv1 / 5.e-1 / ! Threshold | history = 2, 3 326 327 data vvap1 /-6.e3 / ! Vapor Pressure Coefficient 328 data vvap2 / 0.4 / ! Vapor Pressure Exponent 329 330 data vgrat1 /0.05 / ! Boundary weak/mid grad(T) 331 data vgrat2 /0.15 / ! Boundary mid/strong grad(T) 332 data vfi /0.09 / ! PHI, strong grad(T) 333 334 data vvisc1 / 0.70 / ! Viscosity Coefficients 335 data vvisc2 / 1.11e5 / ! 336 data vvisc3 /23.00 / ! 337 data vvisc4 / 0.10 / ! 338 data vvisc5 / 1.00 / ! id., wet Snow 339 data vvisc6 / 2.00 / ! 340 data vvisc7 /10.00 / ! 341 data rovisc / 0.25 / ! Wet Snow Density Influence 342 data vdz3 / 0.30 / ! Maximum Layer Densification 343 344 345 ! +--DATA (Coefficient Fonction fort Gradient Marbouty) 346 ! + -------------------------------------------------- 347 348 data vtang1 /40.0/ ! Temperature Contribution 349 data vtang2 / 6.0/ ! 350 data vtang3 /22.0/ ! 351 data vtang4 / 0.7/ ! 352 data vtang5 / 0.3/ ! 353 data vtang6 / 6.0/ ! 354 data vtang7 / 1.0/ ! 355 data vtang8 / 0.8/ ! 356 data vtang9 /16.0/ ! 357 data vtanga / 0.2/ ! 358 data vtangb / 0.2/ ! 359 data vtangc /18.0/ ! 360 361 data vrang1 / 0.40/ ! Density Contribution 362 data vrang2 / 0.15/ ! 363 364 data vgang1 / 0.70/ ! Grad(T) Contribution 365 data vgang2 / 0.25/ ! 366 data vgang3 / 0.40/ ! 367 data vgang4 / 0.50/ ! 368 data vgang5 / 0.10/ ! 369 data vgang6 / 0.15/ ! 370 data vgang7 / 0.10/ ! 371 data vgang8 / 0.55/ ! 372 data vgang9 / 0.65/ ! 373 data vganga / 0.20/ ! 374 data vgangb / 0.85/ ! 375 data vgangc / 0.15/ ! 376 377 ! #wp data D__MAX / 4.00/ ! 378 379 380 ! +-- 1. Metamorphoses dans les Strates 381 ! + Metamorphism 382 ! + ============================== 383 384 dt__SV2= dt__SV 385 frac_j = dt__SV2 / 86400. ! Time Step [Day] 386 387 zn4_SV = 0 388 389 390 ! +-- 1.1 Initialisation: teneur en eau liquide et gradient de temperature 391 ! + ------------------ liquid water content and temperature gradient 392 393 DO ikl=1,knonv 394 DO isn=1,isnoSV(ikl) 395 396 ro_dry(ikl,isn) = 1.e-3 *ro__SV(ikl,isn) & ! Dry Density 397 *(1. -eta_SV(ikl,isn)) ! [g/cm3] 398 etaSno(ikl,isn) = 1.e-1 *dzsnSV(ikl,isn) & ! Liquid Water 399 * ro__SV(ikl,isn) & ! Content [g/cm2] 400 * eta_SV(ikl,isn) ! 401 END DO 402 END DO 403 404 !!$OMP PARALLEL DO default(firstprivate) 405 !!$OMP.shared (/xSISVAT_I/,/xSISVAT_R/,/SoR0SV/,/SoI0SV/,/Sn_dSV/) 406 DO ikl=1,knonv 407 DO isn=1,isnoSV(ikl) 408 isnp = min(isn+1,isnoSV(ikl)) 409 410 dTsndz = abs( (TsisSV(ikl,isnp)-TsisSV(ikl,isn-1)) *2.e-2 & 411 /max(((dzsnSV(ikl,isnp)+dzsnSV(ikl,isn) ) & 412 *( isnp - isn) & 413 +(dzsnSV(ikl,isn )+dzsnSV(ikl,isn-1))),epsi)) 414 ! +... Factor 1.d-2 for Conversion K/m --> K/cm 415 416 417 ! +-- 1.2 Metamorphose humide 418 ! + Wet Snow Metamorphism 419 ! + --------------------- 420 421 Wet_OK = max(zero,sign(unun,eta_SV(ikl,isn)-epsi)) 422 423 424 ! +-- Vitesse de diminution de la dendricite 425 ! + Rate of the dendricity decrease 426 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 427 sWater=1.d-1*ro__SV(ikl,isn)*eta_SV(ikl,isn) & 428 /max(epsi,ro_dry(ikl,isn)) 429 ! +... sWater:Water Content [%] 430 ! + 1.d-1= 1.d2(1->%) * 1.d-3(ro__SV*eta_SV:kg/m3->g/cm3) 431 432 exp1Wa= sWater**nvdent1 433 dDENDR=max(exp1Wa/nvdent2,vdent1*exp(vvap1/TfSnow)) 434 435 ! +-- 1.2.1 Cas dendritique/dendritic Case 436 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 437 OK__wd=max(zero, & ! 438 sign(unun,-G1snSV(ikl,isn) & ! 439 -epsi )) ! 440 441 DENDRn=-G1snSV(ikl,isn)/G1_dSV ! Normalized Dendricity (+) 442 SPHERn= G2snSV(ikl,isn)/G1_dSV ! Normalized Sphericity 443 DENDRn= DENDRn -dDENDR *frac_j ! New Dendricity (+) 444 SPHERn= SPHERn +dDENDR *frac_j ! New Sphericity 445 446 OK__DE=max(zero, & ! IF 1., 447 sign(unun, DENDRn & ! NO change 448 -epsi )) ! Dendr. -> Spheric 449 450 G1__wd=OK__DE * ( -DENDRn*G1_dSV) & ! Dendritic 451 +(1.-OK__DE)* min(G1_dSV,SPHERn*G1_dSV) ! Dendr. -> Spheric 452 G2__wd=OK__DE * min(G1_dSV,SPHERn*G1_dSV) & ! Spheric 453 +(1.-OK__DE)*(ADSdSV-min(SPHERn,vsphe1)) ! Spher. -> Size 454 455 ! +-- 1.2.2 Cas non dendritique non completement spherique 456 ! + Evolution de la Sphericite seulement. 457 ! + Non dendritic and not completely spheric Case 458 ! + Evolution of Sphericity only (not size) 459 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 460 OK__ws=max(zero, & ! 461 sign(unun, G1_dSV & ! 462 -epsi5 & ! 463 -G1snSV(ikl,isn))) ! 464 465 SPHERn= G1snSV(ikl,isn)/G1_dSV 466 SPHERn= SPHERn +dDENDR *frac_j 467 G1__ws= min(G1_dSV,SPHERn*G1_dSV) 468 469 ! +-- 1.2.3 Cas non dendritique et spherique / non dendritic and spheric 470 ! + Evolution de la Taille seulement / Evolution of Size only 471 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 472 G2__ws = husi_0 & 473 *( husi_1 & 474 *(husi_2 *( G2snSV(ikl,isn)/husi_0)**3 & 475 +(vtail1 +vtail2 *exp1Wa )*dt__SV2)) & 476 ** husi_3 477 478 479 ! +-- 1.3 Metamorposes seches / Dry Metamorphism 480 ! + -------------------------------------- 481 482 483 ! +-- 1.3.1 Calcul Metamorphose faible/low Gradient (0.00-0.05 deg/cm) 484 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 485 OKlowT=max(zero, & ! 486 sign(unun, vgrat1 & ! 487 -dTsndz )) ! 488 489 facVap=exp(vvap1/TsisSV(ikl,isn)) 490 491 ! +-- 1.3.1.1 Cas dendritique / dendritic Case 492 493 OK_ldd=max(zero, & ! 494 sign(unun,-G1snSV(ikl,isn) & ! 495 -epsi )) ! 496 497 DENDRn=-G1snSV(ikl,isn) /G1_dSV 498 SPHERn= G2snSV(ikl,isn) /G1_dSV 499 DENDRn= DENDRn-vdent1*facVap*frac_j 500 SPHERn= SPHERn+vsphe2*facVap*frac_j 501 502 OK__DE=max(zero, & ! IF 1., 503 sign(unun, DENDRn & ! NO change 504 -epsi )) ! Dendr. -> Spheric 505 506 G1_ldd= OK__DE * ( -DENDRn*G1_dSV) & ! Dendritic 507 +(1.-OK__DE)* min(G1_dSV,SPHERn*G1_dSV) ! Dendr. -> Spheric 508 G2_ldd= OK__DE * min(G1_dSV,SPHERn*G1_dSV) & ! Spheric 509 +(1.-OK__DE)*(ADSdSV-min(SPHERn,vsphe1)) ! Spher. -> Size 510 511 ! +-- 1.3.1.2 Cas non dendritique / non dendritic Case 512 513 SPHERn=G1snSV(ikl,isn)/G1_dSV 514 DiamGx=G2snSV(ikl,isn)*0.1 515 516 istoOK=min( abs(istoSV(ikl,isn)- & 517 istdSV(1) ),1) ! zero if istoSV = 1 518 DiamOK=max(zero, sign(unun,vdiam2-DiamGx)) 519 No_Big= istoOK+DiamOK 520 No_Big=min(No_Big,unun) 521 522 dSPHER= vsphe2*facVap*frac_j ! 523 SPHER0= SPHERn+dSPHER ! small grains 524 SPHbig= SPHERn+dSPHER & ! big grains 525 *exp(min(zero,vdiam3-G2snSV(ikl,isn))) ! (history = 2 or 3) 526 SPHbig= min(vsphe3,SPHbig) ! limited sphericity 527 SPHERn= No_Big * SPHER0 & 528 + (1.-No_Big)* SPHbig 529 530 G1_lds= min(G1_dSV,SPHERn*G1_dSV) 531 532 ! +-- 1.3.2 Calcul Metamorphose Gradient Moyen/Moderate (0.05-0.15) 533 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 534 OK_mdT=max(zero, & ! 535 sign(unun, vgrat2 & ! 536 -dTsndz)) ! 537 OKmidT= OK_mdT *(1.-OKlowT) ! 538 OKhigT= (1. -OK_mdT) *(1.-OKlowT) ! 539 540 facVap=vdent1*exp(vvap1/TsisSV(ikl,isn)) & 541 * (1.e2 *dTsndz)**vvap2 542 543 ! +-- 1.3.2.1 cas dendritique / dendritic case. 544 545 OK_mdd=max(zero, & ! 546 sign(unun,-G1snSV(ikl,isn) & ! 547 -epsi )) ! 548 549 DENDRn=-G1snSV(ikl,isn)/G1_dSV 550 SPHERn= G2snSV(ikl,isn)/G1_dSV 551 DENDRn= DENDRn - facVap*frac_j 552 SPHERn= SPHERn - facVap*frac_j 553 554 OK__DE=max(zero, & ! IF 1., 555 sign(unun, DENDRn & ! NO change 556 -epsi )) ! Dendr. -> Spheric 557 558 G1_mdd= OK__DE * ( -DENDRn*G1_dSV) & ! Dendritic 559 +(1.-OK__DE)* max(zero ,SPHERn*G1_dSV) ! Dendr. -> Spheric 560 G2_mdd= OK__DE * max(zero ,SPHERn*G1_dSV) & ! Spheric 561 +(1.-OK__DE)*(ADSdSV-max(SPHERn,zero )) ! Spher. -> Size 562 563 ! +-- 1.3.2.2 Cas non dendritique / non dendritic Case 564 565 SPHERn=G1snSV(ikl,isn)/G1_dSV 566 SPHERn= SPHERn-facVap*frac_j 567 G1_mds=max(zero,SPHERn*G1_dSV) 568 569 ! +-- 1.3.3 Calcul Metamorphose fort / high Gradient 570 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 571 facVap=vdent1*exp(vvap1/TsisSV(ikl,isn)) & 572 * (1.e2 *dTsndz)**vvap2 573 574 ! +-- 1.3.3.1 Cas dendritique / dendritic Case 575 576 OK_hdd=max(zero, & ! 577 sign(unun,-G1snSV(ikl,isn) & ! 578 -epsi )) ! 579 580 DENDRn=-G1snSV(ikl,isn)/G1_dSV ! 581 SPHERn= G2snSV(ikl,isn)/G1_dSV ! 582 DENDRn= DENDRn - facVap*frac_j ! 583 SPHERn= SPHERn - facVap*frac_j ! Non dendritic 584 ! + ! and angular 585 OK__DE=max(zero, & ! IF 1., 586 sign(unun, DENDRn & ! NO change 587 -epsi )) ! Dendr. -> Spheric 588 589 G1_hdd= OK__DE * ( -DENDRn*G1_dSV) & ! Dendritic 590 +(1.-OK__DE)* max(zero ,SPHERn*G1_dSV) ! Dendr. -> Spheric 591 G2_hdd= OK__DE * max(zero ,SPHERn*G1_dSV) & ! Spheric 592 +(1.-OK__DE)*(ADSdSV-max(SPHERn,zero )) ! Spher. -> Size 593 594 ! +-- 1.3.3.2 Cas non dendritique non completement anguleux. 595 ! + non dendritic and spericity gt. 0 596 597 OK_hds=max(zero, & ! 598 sign(unun, G1snSV(ikl,isn) & ! 599 -epsi )) ! 600 601 SPHERn= G1snSV(ikl,isn)/G1_dSV 602 SPHERn= SPHERn - facVap*frac_j 603 G1_hds= max(zero,SPHERn*G1_dSV) 604 605 ! +-- 1.3.3.3 Cas non dendritique et anguleux 606 ! + dendritic and spericity = 0. 607 608 T1__OK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang1)) 609 T2__OK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang2)) 610 T3_xOK = max(zero,sign(unun,TsisSV(ikl,isn)-TfSnow+vtang3)) 611 T3__OK = T3_xOK * (1. - T2__OK) 612 T3_nOK = (1. - T3_xOK) * (1. - T2__OK) 613 ro1_OK = max(zero,sign(unun,vrang1-ro_dry(ikl,isn))) 614 ro2_OK = max(zero,sign(unun,ro_dry(ikl,isn)-vrang2)) 615 dT1_OK = max(zero,sign(unun,vgang1-dTsndz )) 616 dT2_OK = max(zero,sign(unun,vgang2-dTsndz )) 617 dT3xOK = max(zero,sign(unun,vgang3-dTsndz )) 618 dT3_OK = dT3xOK * (1. - dT2_OK) 619 dT4xOK = max(zero,sign(unun,vgang4-dTsndz )) 620 dT4_OK = dT4xOK * (1. - dT3_OK) & 621 * (1. - dT2_OK) 622 dT4nOK = (1. - dT4xOK) * (1. - dT3_OK) & 623 * (1. - dT2_OK) 624 625 ! +-- Influence de la Temperature /Temperature Influence 626 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 627 AngSno = & 628 T1__OK & ! 11 629 *(T2__OK*(vtang4+vtang5*(TfSnow -TsisSV(ikl,isn)) & ! 12 630 /vtang6) & ! 631 +T3__OK*(vtang7-vtang8*(TfSnow-vtang2-TsisSV(ikl,isn)) & ! 13 632 /vtang9) & ! 633 +T3_nOK*(vtanga-vtangb*(TfSnow-vtang3-TsisSV(ikl,isn)) & ! 14 634 /vtangc)) & ! 635 636 ! +-- Influence de la Masse Volumique /Density Influence 637 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 638 * ro1_OK & 639 *( ro2_OK*(1. - (ro_dry(ikl,isn)-vrang2) & ! 640 /(vrang1-vrang2)) & ! 641 +1.-ro2_OK ) & ! 642 643 ! +-- Influence du Gradient de Temperature /Temperature Gradient Influence 644 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 645 *( dT1_OK*(dT2_OK*vgang5*(dTsndz-vgang6) & ! 15 646 /(vgang2-vgang6) & ! 647 +dT3_OK*vgang7 & ! 16 648 +dT4_OK*vgang9 & ! 17 649 +dT4nOK*vgangb ) & ! 18 650 +1.-dT1_OK ) & ! 651 + ro1_OK & 652 * dT1_OK*(dT3_OK*vgang8*(dTsndz-vgang2) & 653 /(vgang3-vgang2) & 654 +dT4_OK*vganga*(dTsndz-vgang3) & 655 /(vgang4-vgang3) & 656 +dT4nOK*vgangc*(dTsndz-vgang4) & 657 /(vgang1-vgang4)) 658 659 G2_hds = G2snSV(ikl,isn) + 1.d2 *AngSno*vfi *frac_j 660 661 662 ! +--New Properties 663 ! + -------------- 664 665 G1_bak = G1snSV(ikl,isn) 666 G2_bak = G2snSV(ikl,isn) 667 668 G1snSV(ikl,isn) = Wet_OK * ( OK__wd *G1__wd & ! 1 669 +(1.-OK__wd)* OK__ws *G1__ws & ! 2 670 +(1.-OK__wd)*(1.-OK__ws)*G1_bak) & ! 3 671 +(1. - Wet_OK) & ! 672 *( OKlowT *( OK_ldd *G1_ldd & ! 4 673 +(1.-OK_ldd) *G1_lds) & ! 5 674 + OKmidT *( OK_mdd *G1_mdd & ! 6 675 +(1.-OK_mdd) *G1_mds) & ! 7 676 + OKhigT *( OK_hdd *G1_hdd & ! 8 677 +(1.-OK_hdd)* OK_hds *G1_hds & ! 9 678 +(1.-OK_hdd)*(1.-OK_hds)*G1_bak)) ! 10 679 680 !XF 681 if(G1snSV(ikl,isn)<0.1) & 682 G2_hds = G2snSV(ikl,isn) + 1.d1 *AngSno*vfi *frac_j 683 !XF 684 685 686 G2snSV(ikl,isn) = Wet_OK * ( OK__wd *G2__wd & ! 1 687 +(1.-OK__wd)* OK__ws *G2_bak & ! 2 688 +(1.-OK__wd)*(1.-OK__ws)*G2__ws) & ! 3 689 +(1. - Wet_OK) & ! 690 *( OKlowT *( OK_ldd *G2_ldd & ! 4 691 +(1.-OK_ldd) *G2_bak) & ! 5 692 + OKmidT *( OK_mdd *G2_mdd & ! 6 693 +(1.-OK_mdd) *G2_bak) & ! 7 694 + OKhigT *( OK_hdd *G2_hdd & ! 8 695 +(1.-OK_hdd)* OK_hds *G2_bak & ! 9 696 +(1.-OK_hdd)*(1.-OK_hds)*G2_hds)) ! 10 697 698 ! +--Snow Properties: IO Set Up 699 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~ 700 ! #vp G_curr( 1) = Wet_OK * OK__wd 701 ! #vp G_curr( 2) = Wet_OK *(1.-OK__wd)* OK__ws 702 ! #vp G_curr( 3) = Wet_OK *(1.-OK__wd)*(1.-OK__ws) 703 ! #vp G_curr( 4) = (1.-Wet_OK)* OKlowT * OK_ldd 704 ! #vp G_curr( 5) = (1.-Wet_OK)* OKlowT *(1.-OK_ldd) 705 ! #vp G_curr( 6) = (1.-Wet_OK)* OKmidT * OK_mdd 706 ! #vp G_curr( 7) = (1.-Wet_OK)* OKmidT *(1.-OK_mdd) 707 ! #vp G_curr( 8) = (1.-Wet_OK)* OKhigT * OK_hdd 708 ! #vp G_curr( 9) = (1.-Wet_OK)* OKhigT *(1.-OK_hdd)* OK_hds 709 ! #vp G_curr(10) = (1.-Wet_OK)* OKhigT *(1.-OK_hdd)*(1.-OK_hds) 710 ! #vp G_curr(11) = T1__OK * G_curr(10) 711 ! #vp G_curr(12) = T2__OK * G_curr(10) 712 ! #vp G_curr(13) = T3__OK * G_curr(10) 713 ! #vp G_curr(14) = T3_nOK * G_curr(10) 714 ! #vp G_curr(15) = ro1_OK* dT1_OK * dT2_OK * G_curr(10) 715 ! #vp G_curr(16) = ro1_OK* dT1_OK * dT3_OK * G_curr(10) 716 ! #vp G_curr(17) = ro1_OK* dT1_OK * dT4_OK * G_curr(10) 717 ! #vp G_curr(18) = ro1_OK* dT1_OK * dT4nOK * G_curr(10) 718 719 ! #vp Gcases( 1) = max(Gcases( 1),G_curr( 1)) 720 ! #vp Gcases( 2) = max(Gcases( 2),G_curr( 2)) 721 ! #vp Gcases( 3) = max(Gcases( 3),G_curr( 3)) 722 ! #vp Gcases( 4) = max(Gcases( 4),G_curr( 4)) 723 ! #vp Gcases( 5) = max(Gcases( 5),G_curr( 5)) 724 ! #vp Gcases( 6) = max(Gcases( 6),G_curr( 6)) 725 ! #vp Gcases( 7) = max(Gcases( 7),G_curr( 7)) 726 ! #vp Gcases( 8) = max(Gcases( 8),G_curr( 8)) 727 ! #vp Gcases( 9) = max(Gcases( 9),G_curr( 9)) 728 ! #vp Gcases(10) = max(Gcases(10),G_curr(10)) 729 ! #vp Gcases(11) = max(Gcases(11),G_curr(11)) 730 ! #vp Gcases(12) = max(Gcases(12),G_curr(12)) 731 ! #vp Gcases(13) = max(Gcases(13),G_curr(13)) 732 ! #vp Gcases(14) = max(Gcases(14),G_curr(14)) 733 ! #vp Gcases(15) = max(Gcases(15),G_curr(15)) 734 ! #vp Gcases(16) = max(Gcases(16),G_curr(16)) 735 ! #vp Gcases(17) = max(Gcases(17),G_curr(17)) 736 ! #vp Gcases(18) = max(Gcases(18),G_curr(18)) 737 738 ! +--Snow Properties: IO 739 ! + ~~~~~~~~~~~~~~~~~~~ 740 ! #vp IF (isn .le. isnoSV(ikl)) 741 ! #vp. write(47,471)isn ,isnoSV(ikl) , 742 ! #vp. TsisSV(ikl,isn),ro__SV(ikl,isn),eta_SV(ikl,isn), 743 ! #vp. G1_bak ,G2_bak ,istoSV(ikl,isn), 744 ! #vp. dTsndz, 745 ! #vp. ( k ,k=1,18), 746 ! #vp. (G_curr(k),k=1,18), 747 ! #vp. (Gcases(k),k=1,18), 748 ! #vp. Wet_OK,OK__wd,G1__wd,G2__wd, 749 ! #vp. 1.-OK__wd,OK__ws,G1__ws,1.-OK__ws,G2__ws, 750 ! #vp. 1.-Wet_OK,OKlowT,OK_ldd,G1_ldd, G2_ldd, 751 ! #vp. 1.-OK_ldd,G1_lds, 752 ! #vp. OKmidT,OK_mdd,G1_mdd, G1_mdd, 753 ! #vp. 1.-OK_mdd,G1_mds, 754 ! #vp. OKhigT,OK_hdd,G1_hdd, G2_hdd, 755 ! #vp. 1.-OK_hdd,OK_hds, G1_hds, 756 ! #vp. 1.-OK_hds,G2_hds, 757 ! #vp. G1snSV(ikl,isn), 758 ! #vp. G2snSV(ikl,isn) 759 760 END DO 761 END DO 762 !!$OMP END PARALLEL DO 763 764 ! +-- 2. Mise a Jour Variables Historiques (Cas non dendritique) 765 ! + Update of the historical Variables 766 ! + ======================================================= 767 768 IF (vector) THEN 769 !XF 770 DO ikl=1,knonv 771 DO isn=1,isnoSV(ikl) 772 SphrOK = max(zero,sign(unun, G1snSV(ikl,isn))) 773 H1a_OK = max(zero,sign(unun,vsphe4-G1snSV(ikl,isn))) 774 H1b_OK = 1 - min(1 , istoSV(ikl,isn)) 775 H1__OK = H1a_OK*H1b_OK 776 H23aOK = max(zero,sign(unun,vsphe4-G1_dSV & 777 +G1snSV(ikl,isn))) 778 H23bOK = max(zero,sign(unun,etaSno(ikl,isn) & 779 /max(epsi,dzsnSV(ikl,isn)) & 780 -vtelv1 )) 781 H23_OK = H23aOK*H23bOK 782 H2__OK = 1 - min(1 , istoSV(ikl,isn)) 783 H3__OK = 1 - min(1 , abs(istoSV(ikl,isn)-istdSV(1))) 784 H45_OK = max(zero,sign(unun,TfSnow-TsisSV(ikl,isn)+epsi)) 785 H4__OK = 1 - min(1 , abs(istoSV(ikl,isn)-istdSV(2))) 786 H5__OK = 1 - min(1 , abs(istoSV(ikl,isn)-istdSV(3))) 787 788 HISupd = & 789 SphrOK*(H1__OK *istdSV(1) & 790 +(1.-H1__OK)* H23_OK *(H2__OK*istdSV(2) & 791 +H3__OK*istdSV(3)) & 792 +(1.-H1__OK)*(1.-H23_OK) *H45_OK*(H4__OK*istdSV(4) & 793 +H5__OK*istdSV(5))) 794 istoSV(ikl,isn) = HISupd + & 795 (1.-min(unun,HISupd)) *istoSV(ikl,isn) 796 END DO 797 END DO 798 ELSE 799 800 801 ! +-- 2. Mise a Jour Variables Historiques (Cas non dendritique) 802 ! + Update of the historical Variables 803 ! + ======================================================= 804 805 DO ikl=1,knonv 806 DO isn=iiceSV(ikl),isnoSV(ikl) 807 IF (G1snSV(ikl,isn).ge.0.) THEN 808 IF(G1snSV(ikl,isn).lt.vsphe4.and.istoSV(ikl,isn).eq.0) THEN 809 istoSV(ikl,isn)=istdSV(1) 810 ELSEIF(G1_dSV-G1snSV(ikl,isn) .lt.vsphe4.and. & 811 etaSno(ikl,isn)/dzsnSV(ikl,isn).gt.vtelv1) THEN 812 IF (istoSV(ikl,isn).eq.0) & 813 istoSV(ikl,isn)= istdSV(2) 814 IF (istoSV(ikl,isn).eq.istdSV(1)) & 815 istoSV(ikl,isn)= istdSV(3) 816 ELSEIF(TsisSV(ikl,isn).lt.TfSnow) THEN 817 IF (istoSV(ikl,isn).eq.istdSV(2)) & 818 istoSV(ikl,isn)= istdSV(4) 819 IF (istoSV(ikl,isn).eq.istdSV(3)) & 820 istoSV(ikl,isn)= istdSV(5) 821 END IF 825 822 END IF 826 827 828 C +-- 3. Tassement mecanique /mechanical Settlement 829 C + ========================================== 830 831 DO ikl=1,knonv 832 SnMass(ikl) = 0. 833 END DO 834 cXF 835 DO ikl=1,knonv 836 837 smb_old = 0. 838 zn_old = 0 839 DO isn = 1, isnoSV(ikl) 840 smb_old = smb_old + dzsnSV(ikl,isn) *ro__SV(ikl,isn) 841 zn_old = zn_old + dzsnSV(ikl,isn) 842 ENDDO 843 844 DO isn=isnoSV(ikl),1,-1 845 dSnMas = 100.*dzsnSV(ikl,isn)*ro_dry(ikl,isn) 846 SnMass(ikl)= SnMass(ikl)+0.5*dSnMas 847 ViscSn = vvisc1 *vvisc2 848 . *exp(vvisc3 *ro_dry(ikl,isn) 849 . +vvisc4*abs(TfSnow-TsisSV(ikl,isn))) 850 . *ro_dry(ikl,isn)/rovisc 851 852 C +-- Changement de Viscosite si Teneur en Eau liquide 853 C + Change of the Viscosity if liquid Water Content 854 C + ------------------------------------------------ 855 856 OK_Liq = max(zero,sign(unun,etaSno(ikl,isn)-epsi)) 857 OK_Ang = max(zero,sign(unun,vgran6-G1snSV(ikl,isn))) 858 . *(1-min(1 , abs(istoSV(ikl,isn)-istdSV(1)))) 859 ! #wp IF (G1snSV(ikl,isn).gt.0..AND.G1snSV(ikl,isn).lt.vsphe4 860 ! #wp. .AND.istoSV(ikl,isn).eq. 0) 861 ! #wp. THEN 862 ! #wp write(6,*) ikl,isn,' G1,G2,hist,OK_Ang ', 863 ! #wp. G1snSV(ikl,isn), G2snSV(ikl,isn),istoSV(ikl,isn),OK_Ang 864 ! #wp stop "Grains anguleux mal d?finis" 865 ! #wp END IF 866 OKxLiq = max(zero,sign(unun,vtelv1-etaSno(ikl,isn) 867 . /max(epsi,dzsnSV(ikl,isn)))) 868 . * max(0 ,sign(1 ,istoSV(ikl,isn) 869 . -istdSV(1) )) 870 ViscSn = 871 . ViscSn*( OK_Liq/(vvisc5+vvisc6*etaSno(ikl,isn) 872 . /max(epsi,dzsnSV(ikl,isn))) 873 . +(1.-OK_Liq) ) 874 . *( OK_Ang*exp(min(ADSdSV,G2snSV(ikl,isn)-vdiam4)) 875 . +(1.-OK_Ang) ) 876 . *( OKxLiq* vvisc7 877 . +(1.-OKxLiq) ) 878 879 880 C +-- Calcul nouvelle Epaisseur / new Thickness 881 C + ----------------------------------------- 882 883 dzsnew = 884 . dzsnSV(ikl,isn) 885 . *max(vdz3, 886 . (unun-dt__SV2*max(SnMass(ikl)*cos(slopSV(ikl)),unun) 887 . /max(ViscSn ,epsi))) 888 rosnew = ro__SV(ikl,isn) *dzsnSV(ikl,isn) 889 . /max(1e-10,dzsnew) 890 rosmax = 1. /( (1. -eta_SV(ikl,isn)) /ro_Ice 891 . + eta_SV(ikl,isn) /ro_Wat) 892 rosnew = min(rosnew ,rosmax) 893 dzsnew = dzsnSV(ikl,isn) *ro__SV(ikl,isn) 894 . /max(1e-10,rosnew) 895 ro__SV(ikl,isn)= rosnew 896 dzsnSV(ikl,isn)= dzsnew 897 ro_dry(ikl,isn)= ro__SV(ikl,isn)*(1.-eta_SV(ikl,isn))*1.e-3 898 C +... ro_dry: Dry Density (g/cm3) 899 C + 900 SnMass(ikl) = SnMass(ikl)+dSnMas*0.5 901 END DO 902 903 smb_new = 0. 904 DO isn = 1, isnoSV(ikl) 905 smb_new = smb_new + dzsnSV(ikl,isn) *ro__SV(ikl,isn) 906 ENDDO 907 908 isn=1 909 if (dzsnSV(ikl,isn)>0.and.ro__SV(ikl,isn)>0) then 910 dzsnSV(ikl,isn) = dzsnSV(ikl,isn) +0.9999*(smb_old-smb_new) 911 . / ro__SV(ikl,isn) 912 endif 913 914 zn_new = 0 915 DO isn = 1, isnoSV(ikl) 916 zn_new = zn_new + dzsnSV(ikl,isn) 917 ENDDO 918 zn4_SV(ikl) = zn4_SV(ikl) + (zn_new - zn_old) 919 920 END DO 921 922 923 924 return 925 end 823 END DO 824 END DO 825 END IF 826 827 828 ! +-- 3. Tassement mecanique /mechanical Settlement 829 ! + ========================================== 830 831 DO ikl=1,knonv 832 SnMass(ikl) = 0. 833 END DO 834 !XF 835 DO ikl=1,knonv 836 837 smb_old = 0. 838 zn_old = 0 839 DO isn = 1, isnoSV(ikl) 840 smb_old = smb_old + dzsnSV(ikl,isn) *ro__SV(ikl,isn) 841 zn_old = zn_old + dzsnSV(ikl,isn) 842 ENDDO 843 844 DO isn=isnoSV(ikl),1,-1 845 dSnMas = 100.*dzsnSV(ikl,isn)*ro_dry(ikl,isn) 846 SnMass(ikl)= SnMass(ikl)+0.5*dSnMas 847 ViscSn = vvisc1 *vvisc2 & 848 *exp(vvisc3 *ro_dry(ikl,isn) & 849 +vvisc4*abs(TfSnow-TsisSV(ikl,isn))) & 850 *ro_dry(ikl,isn)/rovisc 851 852 ! +-- Changement de Viscosite si Teneur en Eau liquide 853 ! + Change of the Viscosity if liquid Water Content 854 ! + ------------------------------------------------ 855 856 OK_Liq = max(zero,sign(unun,etaSno(ikl,isn)-epsi)) 857 OK_Ang = max(zero,sign(unun,vgran6-G1snSV(ikl,isn))) & 858 *(1-min(1 , abs(istoSV(ikl,isn)-istdSV(1)))) 859 ! #wp IF (G1snSV(ikl,isn).gt.0..AND.G1snSV(ikl,isn).lt.vsphe4 860 ! #wp. .AND.istoSV(ikl,isn).eq. 0) 861 ! #wp. THEN 862 ! #wp write(6,*) ikl,isn,' G1,G2,hist,OK_Ang ', 863 ! #wp. G1snSV(ikl,isn), G2snSV(ikl,isn),istoSV(ikl,isn),OK_Ang 864 ! #wp stop "Grains anguleux mal d?finis" 865 ! #wp END IF 866 OKxLiq = max(zero,sign(unun,vtelv1-etaSno(ikl,isn) & 867 /max(epsi,dzsnSV(ikl,isn)))) & 868 * max(0 ,sign(1 ,istoSV(ikl,isn) & 869 -istdSV(1) )) 870 ViscSn = & 871 ViscSn*( OK_Liq/(vvisc5+vvisc6*etaSno(ikl,isn) & 872 /max(epsi,dzsnSV(ikl,isn))) & 873 +(1.-OK_Liq) ) & 874 *( OK_Ang*exp(min(ADSdSV,G2snSV(ikl,isn)-vdiam4)) & 875 +(1.-OK_Ang) ) & 876 *( OKxLiq* vvisc7 & 877 +(1.-OKxLiq) ) 878 879 880 ! +-- Calcul nouvelle Epaisseur / new Thickness 881 ! + ----------------------------------------- 882 883 dzsnew = & 884 dzsnSV(ikl,isn) & 885 *max(vdz3, & 886 (unun-dt__SV2*max(SnMass(ikl)*cos(slopSV(ikl)),unun) & 887 /max(ViscSn ,epsi))) 888 rosnew = ro__SV(ikl,isn) *dzsnSV(ikl,isn) & 889 /max(1e-10,dzsnew) 890 rosmax = 1. /( (1. -eta_SV(ikl,isn)) /ro_Ice & 891 + eta_SV(ikl,isn) /ro_Wat) 892 rosnew = min(rosnew ,rosmax) 893 dzsnew = dzsnSV(ikl,isn) *ro__SV(ikl,isn) & 894 /max(1e-10,rosnew) 895 ro__SV(ikl,isn)= rosnew 896 dzsnSV(ikl,isn)= dzsnew 897 ro_dry(ikl,isn)= ro__SV(ikl,isn)*(1.-eta_SV(ikl,isn))*1.e-3 898 ! +... ro_dry: Dry Density (g/cm3) 899 ! + 900 SnMass(ikl) = SnMass(ikl)+dSnMas*0.5 901 END DO 902 903 smb_new = 0. 904 DO isn = 1, isnoSV(ikl) 905 smb_new = smb_new + dzsnSV(ikl,isn) *ro__SV(ikl,isn) 906 ENDDO 907 908 isn=1 909 if (dzsnSV(ikl,isn)>0.and.ro__SV(ikl,isn)>0) then 910 dzsnSV(ikl,isn) = dzsnSV(ikl,isn) +0.9999*(smb_old-smb_new) & 911 / ro__SV(ikl,isn) 912 endif 913 914 zn_new = 0 915 DO isn = 1, isnoSV(ikl) 916 zn_new = zn_new + dzsnSV(ikl,isn) 917 ENDDO 918 zn4_SV(ikl) = zn4_SV(ikl) + (zn_new - zn_old) 919 920 END DO 921 922 923 924 return 925 end subroutine sisvat_gsn -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_qsn.f90
r5245 r5246 1 2 3 subroutine SISVAT_qSn 4 . (5 ! #e1. EqSn_0,EqSn_1,EqSn_d6 ! #m1. ,SIsubl,SImelt,SIrnof7 .)8 9 C+------------------------------------------------------------------------+10 C| MAR SISVAT_qSn Fri 29-Jul-2011 MAR |11 C| SubRoutine SISVAT_qSn updates the Snow Water Content |12 C+------------------------------------------------------------------------+13 C| |14 C| PARAMETERS: knonv: Total Number of columns = |15 C| ^^^^^^^^^^ = Total Number of continental grid boxes |16 C| X Number of Mosaic Cell per grid box |17 C| |18 C| INPUT: isnoSV = total Nb of Ice/Snow Layers |19 C| ^^^^^ |20 C| |21 C| INPUT: TaT_SV : SBL Top Temperature [K] |22 C| ^^^^^ dt__SV : Time Step [s] |23 C| |24 C| INPUT / drr_SV : Rain Intensity [kg/m2/s] |25 C| OUTPUT: dzsnSV : Snow Layer Thickness [m] |26 C| ^^^^^^ eta_SV : Snow Water Content [m3/m3] |27 C| ro__SV : Snow/Soil Volumic Mass [kg/m3] |28 C| TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|29 C| & Snow Temperatures (layers 1,2,...,nsno) [K] |30 C| |31 C| OUTPUT: SWS_SV : Surficial Water Status |32 C| ^^^^^^ |33 C| EExcsv : Snow Energy in Excess, initial Forcing [J/m2] |34 C| EqSn_d : Snow Energy in Excess, remaining [J/m2] |35 C| EqSn_0 : Snow Energy, before Phase Change [J/m2] |36 C| EqSn_1 : Snow Energy, after Phase Change [J/m2] |37 C| SIsubl : Snow sublimed/deposed Mass [mm w.e.] |38 C| SImelt : Snow Melted Mass [mm w.e.] |39 C| SIrnof : Surficial Water + Run OFF Change [mm w.e.] |40 C| |41 C| Internal Variables: |42 C| ^^^^^^^^^^^^^^^^^^ |43 C| |44 C| # OPTIONS: #E0: IO for Verification: Energy Budget |45 C| # ^^^^^^^ |46 C| # #su: IO for Verification: Slush Diagnostic |47 C| |48 C| |49 C+------------------------------------------------------------------------+50 51 52 53 54 C+--Global Variables55 C+ ================56 57 58 59 60 61 62 63 64 65 66 67 68 69 ! Energy Budget70 ! ~~~~~~~~~~~~~~~~~~~~~~71 ! #e1 real EqSn_d(knonv) ! Energy in Excess, initial72 ! #e1 real EqSn_0(knonv) ! Snow Energy, befor Phase Change73 ! #vm real EqSn01(knonv) ! Snow Energy, after Phase Change74 ! #vm real EqSn02(knonv) ! Snow Energy, after Phase Change75 76 ! #e1 real EqSn_1(knonv) ! Snow Energy, after Phase Change77 78 ! Snow/Ice (Mass) Budget79 ! ~~~~~~~~~~~~~~~~~~~~~~80 ! #m1 real SIsubl(knonv) ! Snow Deposed Mass81 ! #m1 real SImelt(knonv) ! Snow Melted Mass82 ! #m1 real SIrnof(knonv) ! Local Surficial Water + Run OFF83 84 85 C+--Internal Variables86 C+ ==================87 88 integerikl ,isn !89 integernh ! Non erodible Snow: up.lay.Index90 integerLayrOK ! 1 (0) if In(Above) Snow Pack91 integerk_face ! 1 (0) if Crystal(no) faceted92 integerLastOK ! 1 ==> 1! Snow Layer93 integerNOLayr ! 1 Layer Update94 integernoSnow(knonv) ! Nb of Layers Updater95 integerkSlush ! Slush Switch96 realdTSnow ! Temperature [C]97 realEExdum(knonv) ! Energy in Excess when no Snow98 realOKmelt ! 1 (0) if (no) Melting99 realEnMelt ! Energy in excess, for Melting100 realSnHLat ! Energy consumed in Melting101 realAdEnrg,B_Enrg ! Additional Energy from Vapor102 realdzVap0,dzVap1 ! Vaporized Thickness [m]103 realdzMelt(knonv) ! Melted Thickness [m]104 realrosDry ! Snow volumic Mass if no Water in105 realPorVol ! Pore volume106 realPClose ! Pore Hole Close OFF Switch107 realSGDiam ! Snow Grain Diameter108 realSGDmax ! Max. Snow Grain Diameter109 realrWater ! Retained Water [kg/m2]110 realdrrNEW ! New available Water [kg/m2]111 realrdzNEW ! Snow Mass [kg/m2]112 realrdzsno ! Snow Mass [kg/m2]113 realEnFrez ! Energy Release in Freezing114 realWaFrez ! Water consumed in Melting115 realRapdOK ! 1. ==> Snow melts rapidly116 realThinOK ! 1. ==> Snow Layer is thin117 realdzepsi ! Minim. Snow Layer Thickness (!)118 realdz_Min ! Minim. Snow Layer Thickness119 realz_Melt ! Last (thin) Layer Melting120 realrusnew ! Surficial Water Thickness [mm]121 realzWater ! Max Slush Water Thickness [mm]122 realzSlush ! Slush Water Thickness [mm]123 realro_new ! New Snow/ice Density [kg/m3]124 realzc,zt ! Non erod.Snow Thickness[mm w.e.]125 realrusnSV0(knonv)126 realTsave127 128 C+--OUTPUT of SISVAT Trace Statistics (see assignation in PHY_SISVAT)129 C+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~130 integerisnnew,isinew,isnUpD,isnitr131 132 ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)133 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~134 ! #wx integer iSV_v1,jSV_v1,nSV_v1,kSV_v1,lSV_v1135 ! #wx common/SISVAT_EV/ iSV_v1,jSV_v1,nSV_v1,kSV_v1,lSV_v1136 137 C+--Energy and Mass Budget138 C+ ~~~~~~~~~~~~~~~~~~~~~~139 ! #vm real WqSn_0(knonv) ! Snow Water+Forcing Initial140 ! #vm real WqSn_1(knonv) ! Snow Water+Forcing, Final141 ! #vm logical emopen ! IO Switch142 ! #vm common/Se_qSn_L/emopen !143 ! #vm integer no_err !144 ! #vm common/Se_qSn_I/no_err !145 ! #vm real hourer,timeer !146 ! #vm common/Se_qSn_R/timeer !147 148 C+--Slush Diagnostic: IO149 C+ ~~~~~~~~~~~~~~~~~~~~150 ! #vu logical su_opn ! IO Switch151 ! #vu common/SI_qSn_L/su_opn !152 153 154 C+--DATA155 C+ ====156 157 158 c#?? data dz_Min/0.005/ ! Minim. Snow Layer Thickness159 c... Warning: Too high for Col de Porte: precludes 1st snow (layer) apparition160 161 162 163 164 C+--Energy Budget (IN)165 C+ ==================166 167 ! #e1 DO ikl=1,knonv168 ! #e1 EqSn_0(ikl) = 0.169 ! #e1 END DO170 ! #e1 DO isn=nsno,1,-1171 ! #e1 DO ikl=1,knonv172 ! #e1 EqSn_0(ikl) = EqSn_0(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)173 ! #e1. *(Cn_dSV *(TsisSV(ikl,isn) -TfSnow )174 ! #e1. -Lf_H2O *(1. -eta_SV(ikl,isn)))175 ! #e1 END DO176 ! #e1 END DO177 178 179 C+--Water Budget (IN)180 C+ ==================181 182 ! #vm DO ikl=1,knonv183 ! #vm WqSn_0(ikl) = drr_SV(ikl) * dt__SV184 ! #vm. +rusnSV(ikl)185 ! #vm END DO186 ! #vm DO isn=nsno,1,-1187 ! #vm DO ikl=1,knonv188 ! #vm WqSn_0(ikl) = WqSn_0(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)189 ! #vm END DO190 ! #vm END DO191 192 193 C+--Snow Melt Budget194 C+ ================195 196 ! #m1 DO ikl=1,knonv197 ! #m1 SImelt(ikl) = 0.198 ! #m1 SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV199 ! #m1 END DO200 201 202 C+--Initialization203 C+ ==============204 205 206 207 208 209 210 211 212 213 214 215 216 C+--Melting/Freezing Energy217 C+ =======================218 219 C+...REMARK: Snow liquid Water Temperature assumed = TfSnow220 C+ ^^^^^^221 222 EExdum(ikl) = drr_SV(ikl) * C__Wat *(TaT_SV(ikl)-TfSnow)223 .* dt__SV224 225 226 ! #e1 EqSn_d(ikl) = EExcsv(ikl) !227 228 229 230 C+--Surficial Water Status231 C+ ----------------------232 233 234 SWS_SV(ikl) = max(zero,sign(unun,TfSnow235 .-TsisSV(ikl,isnoSV(ikl))))236 237 238 239 240 241 ! EV DO isn=nsno,1,-1242 C+--Energy, store Previous Content243 C+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^244 245 EExcsv(ikl) = EExcsv(ikl)246 . + ro__SV(ikl,isn) * Cn_dSV * dTSnow247 .* dzsnSV(ikl,isn)248 249 250 C+--Water, store Previous Content251 C+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^252 drr_SV(ikl) = drr_SV(ikl)253 . + ro__SV(ikl,isn) * eta_SV(ikl,isn)254 . * dzsnSV(ikl,isn)255 ./ dt__SV256 ro__SV(ikl,isn) =257 .ro__SV(ikl,isn) *(1. - eta_SV(ikl,isn))258 259 260 261 C+--Melting if EExcsv > 0262 C+ ======================263 264 265 266 C+--Energy Consumption267 C+ ^^^^^^^^^^^^^^^^^^268 269 270 noSnow(ikl) = noSnow(ikl)271 . + max(zero ,sign(unun,dzMelt(ikl)!272 . -dzsnSV(ikl ,isn)))! 1 if full Melt273 .*min(1 , max(0 ,1+isnoSV(ikl)-isn)) ! 1 in the Pack274 dzMelt(ikl) =275 .min(dzsnSV(ikl, isn),dzMelt(ikl))276 dzsnSV(ikl,isn) =277 .dzsnSV(ikl,isn) -dzMelt(ikl)278 279 280 281 282 C+--Water Production283 C+ ^^^^^^^^^^^^^^^^^284 drr_SV(ikl) = drr_SV(ikl)285 .+ ro__SV(ikl,isn) * dzMelt(ikl)/dt__SV286 ! #m1 SImelt(ikl) = SImelt(ikl)287 ! #m1. + ro__SV(ikl,isn) * dzMelt(ikl)288 289 290 C+--Snow History291 C+ ^^^^^^^^^^^^292 k_face = min( istoSV(ikl,isn),istdSV(1))! = 1 if293 .*max(0,2-istoSV(ikl,isn) ) ! faceted294 istoSV(ikl,isn) =!295 . (1.-OKmelt) * istoSV(ikl,isn)!296 . + OKmelt *((1-k_face) * istdSV(2)!297 .+ k_face * istdSV(3) ) !298 299 300 C+--Freezing if EExcsv < 0301 C+ ======================302 303 304 305 306 307 308 309 310 311 312 313 314 TsisSV(ikl,isn) = TfSnow315 .+ EnFrez /(Cn_dSV *max(epsi, rdzNEW) )316 317 wer_SV(ikl) = WaFrez318 .+ wer_SV(ikl)319 320 321 322 C+--Snow Water Content323 C+ ==================324 325 C+--Percolation Velocity326 C+ ^^^^^^^^^^^^^^^^^^^^327 c#PW SGDiam = 1.6d-4328 c#PW. + 1.1d-13 *(ro__SV(ikl,isn)*ro__SV(ikl,isn)329 c#PW. *ro__SV(ikl,isn)*ro__SV(ikl,isn))330 331 C+--Pore Volume [-]332 C+ ^^^^^^^^^^^^^^^^^333 334 335 336 337 C+--Water Retention338 C+ ^^^^^^^^^^^^^^^^339 340 341 342 343 rdzNEW = rWater344 .+ rosDry * dzsnSV(ikl,isn)345 346 347 348 C+--Pore Hole Close OFF349 C+ ^^^^^^^^^^^^^^^^^^^350 PClose = max(zero,351 . sign(unun,ro__SV(ikl,isn)352 .-roCdSV ))353 ispiSV(ikl) = ispiSV(ikl) *(1.-PClose)354 .+ max(ispiSV(ikl),isn) * Pclose355 PClose = max(0 ,! Water under SuPer.Ice356 . min (1 ,ispiSV(ikl)! contributes to357 .-isn )) ! Surficial Water358 359 cXF360 if(ro__SV(ikl,isn) >= roCdSV.and.ro__SV(ikl,1)<900)361 . PClose = min(0.50,PClose *362 .(1.-(ro_ice-ro__SV(ikl,isn))/(ro_ice-roCdSV)))363 364 365 366 367 368 369 370 371 372 if((ro__SV(ikl,isn)>900.and.ro__SV(ikl,isn)<920).or.373 .ro__SV(ikl,isn)>950) then374 375 376 377 378 379 380 cif (isn>1.and.isn<nsno .and.381 c. ro__SV(ikl,isn-1)>900 .and.382 c. ro__SV(ikl,isn) >roCdSV .and.383 c. ro__SV(ikl,isn) <900 .and.384 c. TsisSV(ikl,isn) >273.14 .and.385 c. TsisSV(ikl,isn+1)<273.15 .and.386 c. drr_SV(ikl) >0) then387 cTsisSV(ikl,isn)=273.14388 cPClose = 1389 cendif390 391 cXF392 rusnSV(ikl) = rusnSV(ikl)393 .+ drr_SV(ikl) *dt__SV * PClose394 rusnSV0(ikl)= rusnSV0(ikl)395 .+ drr_SV(ikl) *dt__SV * PClose396 397 398 399 400 401 402 403 C+--Remove Zero-Thickness Layers404 C+ ============================405 406 1000 CONTINUE407 408 409 410 411 cXF412 413 414 415 isnnew =(unun-max(zero ,sign(unun,dzsnSV(ikl,isn)-dzepsi)))416 .* max(0 , min(1 ,isnoSV(ikl) +1 -isn ))417 418 419 isinew = isn*isnUpD *max(0, 1-isinew)! LowerMost 0-Layer420 .+isinew ! Index421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 ispiSV(ikl) = ispiSV(ikl)! Nb of SuperI Layer436 .-isnUpD *max(0,min(ispiSV(ikl)-isinew,1)) ! Update if I=0437 438 439 440 441 442 443 C+--New upper Limit of the non erodible Snow (istoSV .GT. 1)444 C+ ========================================445 446 447 448 cXF449 450 451 452 453 454 cXF455 456 zc = zc + dzsnSV(ikl,isn) *ro__SV(ikl,isn)457 .* max(0,min(1,nh+1-isn))458 459 460 461 462 463 464 465 466 C+--Energy Budget (OUT)467 C+ ===================468 469 ! #vm DO ikl=1,knonv470 ! #vm EqSn01(ikl) =-EqSn_0(ikl)471 ! #vm. -EExcsv(ikl)472 ! #vm END DO473 ! #vm DO isn=nsno,1,-1474 ! #vm DO ikl=1,knonv475 ! #vm EqSn01(ikl) = EqSn01(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)476 ! #vm. *(Cn_dSV *(TsisSV(ikl,isn) -TfSnow )477 ! #vm. -Lf_H2O *(1. -eta_SV(ikl,isn)))478 ! #vm END DO479 ! #vm END DO480 481 482 C+--"Negative Heat" from supercooled rain483 C+ ------------------------------------484 485 486 487 488 489 C+--Surficial Water Run OFF490 C+ -----------------------491 492 493 494 495 496 497 c#EU rusnew = 0.498 c#AC rusnew = 0.499 500 RnofSV(ikl) = RnofSV(ikl)501 .+(rusnSV(ikl) - rusnew ) / dt__SV502 RuofSV(ikl,1) = RuofSV(ikl,1)503 .+(rusnSV(ikl) - rusnew ) / dt__SV504 RuofSV(ikl,4) = RuofSV(ikl,4)505 .+(rusnSV0(ikl) ) / dt__SV506 507 508 509 510 C+--Percolation down the Continental Ice Pack511 C+ -----------------------------------------512 513 514 drr_SV(ikl) = drr_SV(ikl) + rusnSV(ikl)515 .* (1-min(1,ispiSV(ikl)))/ dt__SV516 rusnSV(ikl) = rusnSV(ikl)517 .* min(1,ispiSV(ikl))518 519 520 cXF removal of too thin snowlayers if TT> 275.15 + bug if TT>> 273.15521 522 523 524 525 526 527 if(zt<0.005+(TaT_SV(ikl)-TfSnow)/1000..and.528 . isnoSV(ikl) >0 .and.529 . TaT_SV(ikl) >=TfSnow .and.530 .istoSV(ikl,isnoSV(ikl)) >1 ) then531 532 drr_SV(ikl) = drr_SV(ikl)533 .+ dzsnSV(ikl,isn)*ro__SV(ikl,isn) /dt__SV534 535 536 537 538 539 540 541 C+--Slush Formation (Activated. CAUTION: ADD RunOff Possibility before Activation)542 C+ --------------- ^^^^^^^ ^^^543 544 IF (is_ok_slush) THEN545 546 547 548 549 550 C+--Available Additional Pore Volume [-]551 C+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^552 PorVol = 1. - ro__SV(ikl,isn)! [--]553 . *(1. - eta_SV(ikl,isn))/ ro_Ice!554 . - eta_SV(ikl,isn)!555 .*ro__SV(ikl,isn) / ro_Wat !556 557 zWater = dzsnSV(ikl,isn) * PorVol * 1000.! [mm] OR [kg/m2]558 . * (1. -SWS_SV(ikl)! 0 <=> freezing559 .*(1 -min(1,iabs(isn-isnoSV(ikl))))) ! 1 <=> isn=isnoSV560 561 ro_new =(dzsnSV(ikl,isn) * ro__SV(ikl,isn)!562 . +zSlush )!563 ./ max(dzsnSV(ikl,isn) , epsi ) !564 565 566 567 eta_SV(ikl,isn) =(ro_new - ro__SV(ikl,isn)!568 . *(1. - eta_SV(ikl,isn)))!569 ./ max (ro_new , epsi ) !570 571 572 573 574 575 576 C+--Impact of the Sublimation/Deposition on the Surface Mass Balance577 C+ ================================================================578 579 580 581 dzVap0 = dt__SV582 . * HLs_sv(ikl) * min(isn , 1 )583 ./(Lx_H2O(ikl) * max(ro__SV(ikl,isn) , epsi))584 585 586 587 588 C+--Additional Energy589 C+ -----------------590 591 c#VH AdEnrg = dzVap0 * ro__SV(ikl,isnoSV(ikl)) ! Water Vapor592 c#VH. *C__Wat *(TsisSV(ikl,isnoSV(ikl)) -TfSnow) ! Sensible Heat593 594 c#aH B_Enrg =(Cn_dSV *(TsisSV(ikl,isn) -TfSnow )595 c#aH. -Lf_H2O *(1. -eta_SV(ikl,isn)))596 c#aH. /(1. + dzVap0 /max(epsi,dzsnSV(ikl,isn)))597 c#aH eta_SV(ikl,isn) =598 c#aH. max(zero,unun +(B_Enrg599 c#aH. -(TsisSV(ikl,isn) -TfSnow)*Cn_dSV)600 c#aH. /Lf_H2O )601 c#aH TsisSV(ikl,isn) = ( B_Enrg602 c#aH. +(1. -eta_SV(ikl,isn))603 c#aH. *Lf_H2O )604 c#aH. / Cn_dSV605 c#aH. + TfSnow606 607 ! #e1 STOP "PLEASE add Energy (#aH) from deposition/sublimation"608 609 610 C+--Update of the upper Snow layer Thickness611 C+ ----------------------------------------612 613 dzsnSV(ikl,isn) =614 .max(zero, dzsnSV(ikl,isnoSV(ikl)) + dzVap0)615 616 617 618 619 620 621 622 623 C+--Energy Budget (OUT)624 C+ ===================625 626 ! #vm DO ikl=1,knonv627 ! #vm EqSn02(ikl) =-EqSn_0(ikl)628 ! #vm. -EExcsv(ikl)629 ! #vm END DO630 ! #vm DO isn=nsno,1,-1631 ! #vm DO ikl=1,knonv632 ! #vm EqSn02(ikl) = EqSn01(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)633 ! #vm. *(Cn_dSV *(TsisSV(ikl,isn) -TfSnow )634 ! #vm. -Lf_H2O *(1. -eta_SV(ikl,isn)))635 ! #vm END DO636 ! #vm END DO637 638 639 C+--Snow/I Budget640 C+ -------------641 642 ! #m1 DO ikl=1,knonv643 ! #m1 SIsubl(ikl) = dt__SV*HLs_sv(ikl)*min(isnoSV(ikl),1)644 ! #m1. /Lx_H2O(ikl)645 ! #m1 SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV646 ! #m1. - SIrnof(ikl)647 ! #m1 END DO648 649 650 C+--Anticipated Disappearance of a rapidly Melting too thin Last Snow Layer651 C+ =======================================================================652 653 654 LastOK = min(1 , max(0 ,iiceSV(ikl)-isnoSV(ikl)+2)655 . *min(1 ,isnoSV(ikl)-iiceSV(ikl))656 .+min(1 ,isnoSV(ikl)) )657 658 659 660 661 662 663 EExcsv(ikl) = EExcsv(ikl) - z_Melt *ro__SV(ikl,1)664 .*(1. -eta_SV(ikl,1))*Lf_H2O665 666 C+--Water Production667 C+ ^^^^^^^^^^^^^^^^^668 drr_SV(ikl) = drr_SV(ikl)669 .+ ro__SV(ikl,1) * z_Melt /dt__SV670 671 672 673 C+--Update Nb of Layers674 C+ ===================675 676 677 isnoSV(ikl) = isnoSV(ikl)678 .* min(1,iabs(isnoSV(ikl)-noSnow(ikl)))679 680 681 682 ! Energy Budget (OUT)683 ! ===================684 685 ! #e1 DO ikl=1,knonv686 ! #e1 EqSn_1(ikl) = 0.687 ! #e1 END DO688 ! #e1 DO isn=nsno,1,-1689 ! #e1 DO ikl=1,knonv690 ! #e1 EqSn_1(ikl) = EqSn_1(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn)691 ! #e1. *(Cn_dSV *(TsisSV(ikl,isn) -TfSnow )692 ! #e1. -Lf_H2O *(1. -eta_SV(ikl,isn)))693 ! #e1 END DO694 ! #e1 END DO695 696 697 C+--Water Budget (OUT)698 C+ ===================699 700 ! #vm DO ikl=1,knonv701 ! #vm WqSn_0(ikl) = WqSn_0(ikl)702 ! #vm. + HLs_sv(ikl) * dt__SV703 ! #vm. *min(isnoSV(ikl),1) / Lx_H2O(ikl)704 ! #vm WqSn_1(ikl) = drr_SV(ikl) * dt__SV705 ! #vm. + rusnSV(ikl)706 ! #vm. + RnofSV(ikl) * dt__SV707 ! #vm END DO708 ! #vm DO isn=nsno,1,-1709 ! #vm DO ikl=1,knonv710 ! #vm WqSn_1(ikl) = WqSn_1(ikl)711 ! #vm. + ro__SV(ikl,isn)* dzsnSV(ikl,isn)712 ! #vm END DO713 ! #vm END DO714 715 716 717 end 1 2 3 subroutine SISVAT_qSn & 4 ( & 5 ! #e1. EqSn_0,EqSn_1,EqSn_d 6 ! #m1. ,SIsubl,SImelt,SIrnof 7 ) 8 9 ! +------------------------------------------------------------------------+ 10 ! | MAR SISVAT_qSn Fri 29-Jul-2011 MAR | 11 ! | SubRoutine SISVAT_qSn updates the Snow Water Content | 12 ! +------------------------------------------------------------------------+ 13 ! | | 14 ! | PARAMETERS: knonv: Total Number of columns = | 15 ! | ^^^^^^^^^^ = Total Number of continental grid boxes | 16 ! | X Number of Mosaic Cell per grid box | 17 ! | | 18 ! | INPUT: isnoSV = total Nb of Ice/Snow Layers | 19 ! | ^^^^^ | 20 ! | | 21 ! | INPUT: TaT_SV : SBL Top Temperature [K] | 22 ! | ^^^^^ dt__SV : Time Step [s] | 23 ! | | 24 ! | INPUT / drr_SV : Rain Intensity [kg/m2/s] | 25 ! | OUTPUT: dzsnSV : Snow Layer Thickness [m] | 26 ! | ^^^^^^ eta_SV : Snow Water Content [m3/m3] | 27 ! | ro__SV : Snow/Soil Volumic Mass [kg/m3] | 28 ! | TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 29 ! | & Snow Temperatures (layers 1,2,...,nsno) [K] | 30 ! | | 31 ! | OUTPUT: SWS_SV : Surficial Water Status | 32 ! | ^^^^^^ | 33 ! | EExcsv : Snow Energy in Excess, initial Forcing [J/m2] | 34 ! | EqSn_d : Snow Energy in Excess, remaining [J/m2] | 35 ! | EqSn_0 : Snow Energy, before Phase Change [J/m2] | 36 ! | EqSn_1 : Snow Energy, after Phase Change [J/m2] | 37 ! | SIsubl : Snow sublimed/deposed Mass [mm w.e.] | 38 ! | SImelt : Snow Melted Mass [mm w.e.] | 39 ! | SIrnof : Surficial Water + Run OFF Change [mm w.e.] | 40 ! | | 41 ! | Internal Variables: | 42 ! | ^^^^^^^^^^^^^^^^^^ | 43 ! | | 44 ! | # OPTIONS: #E0: IO for Verification: Energy Budget | 45 ! | # ^^^^^^^ | 46 ! | # #su: IO for Verification: Slush Diagnostic | 47 ! | | 48 ! | | 49 ! +------------------------------------------------------------------------+ 50 51 52 53 54 ! +--Global Variables 55 ! + ================ 56 57 use VARphy 58 use VAR_SV 59 use VARdSV 60 use VAR0SV 61 use VARxSV 62 use VARySV 63 use surface_data, only: is_ok_slush,opt_runoff_ac 64 65 66 IMPLICIT NONE 67 68 69 ! Energy Budget 70 ! ~~~~~~~~~~~~~~~~~~~~~~ 71 ! #e1 real EqSn_d(knonv) ! Energy in Excess, initial 72 ! #e1 real EqSn_0(knonv) ! Snow Energy, befor Phase Change 73 ! #vm real EqSn01(knonv) ! Snow Energy, after Phase Change 74 ! #vm real EqSn02(knonv) ! Snow Energy, after Phase Change 75 ! ! .AND. Last Melting 76 ! #e1 real EqSn_1(knonv) ! Snow Energy, after Phase Change 77 ! ! .AND. Mass Redistr. 78 ! Snow/Ice (Mass) Budget 79 ! ~~~~~~~~~~~~~~~~~~~~~~ 80 ! #m1 real SIsubl(knonv) ! Snow Deposed Mass 81 ! #m1 real SImelt(knonv) ! Snow Melted Mass 82 ! #m1 real SIrnof(knonv) ! Local Surficial Water + Run OFF 83 84 85 ! +--Internal Variables 86 ! + ================== 87 88 integer :: ikl ,isn ! 89 integer :: nh ! Non erodible Snow: up.lay.Index 90 integer :: LayrOK ! 1 (0) if In(Above) Snow Pack 91 integer :: k_face ! 1 (0) if Crystal(no) faceted 92 integer :: LastOK ! 1 ==> 1! Snow Layer 93 integer :: NOLayr ! 1 Layer Update 94 integer :: noSnow(knonv) ! Nb of Layers Updater 95 integer :: kSlush ! Slush Switch 96 real :: dTSnow ! Temperature [C] 97 real :: EExdum(knonv) ! Energy in Excess when no Snow 98 real :: OKmelt ! 1 (0) if (no) Melting 99 real :: EnMelt ! Energy in excess, for Melting 100 real :: SnHLat ! Energy consumed in Melting 101 real :: AdEnrg,B_Enrg ! Additional Energy from Vapor 102 real :: dzVap0,dzVap1 ! Vaporized Thickness [m] 103 real :: dzMelt(knonv) ! Melted Thickness [m] 104 real :: rosDry ! Snow volumic Mass if no Water in 105 real :: PorVol ! Pore volume 106 real :: PClose ! Pore Hole Close OFF Switch 107 real :: SGDiam ! Snow Grain Diameter 108 real :: SGDmax ! Max. Snow Grain Diameter 109 real :: rWater ! Retained Water [kg/m2] 110 real :: drrNEW ! New available Water [kg/m2] 111 real :: rdzNEW ! Snow Mass [kg/m2] 112 real :: rdzsno ! Snow Mass [kg/m2] 113 real :: EnFrez ! Energy Release in Freezing 114 real :: WaFrez ! Water consumed in Melting 115 real :: RapdOK ! 1. ==> Snow melts rapidly 116 real :: ThinOK ! 1. ==> Snow Layer is thin 117 real :: dzepsi ! Minim. Snow Layer Thickness (!) 118 real :: dz_Min ! Minim. Snow Layer Thickness 119 real :: z_Melt ! Last (thin) Layer Melting 120 real :: rusnew ! Surficial Water Thickness [mm] 121 real :: zWater ! Max Slush Water Thickness [mm] 122 real :: zSlush ! Slush Water Thickness [mm] 123 real :: ro_new ! New Snow/ice Density [kg/m3] 124 real :: zc,zt ! Non erod.Snow Thickness[mm w.e.] 125 real :: rusnSV0(knonv) 126 real :: Tsave 127 128 ! +--OUTPUT of SISVAT Trace Statistics (see assignation in PHY_SISVAT) 129 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 130 integer :: isnnew,isinew,isnUpD,isnitr 131 132 ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT) 133 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 134 ! #wx integer iSV_v1,jSV_v1,nSV_v1,kSV_v1,lSV_v1 135 ! #wx common/SISVAT_EV/ iSV_v1,jSV_v1,nSV_v1,kSV_v1,lSV_v1 136 137 ! +--Energy and Mass Budget 138 ! + ~~~~~~~~~~~~~~~~~~~~~~ 139 ! #vm real WqSn_0(knonv) ! Snow Water+Forcing Initial 140 ! #vm real WqSn_1(knonv) ! Snow Water+Forcing, Final 141 ! #vm logical emopen ! IO Switch 142 ! #vm common/Se_qSn_L/emopen ! 143 ! #vm integer no_err ! 144 ! #vm common/Se_qSn_I/no_err ! 145 ! #vm real hourer,timeer ! 146 ! #vm common/Se_qSn_R/timeer ! 147 148 ! +--Slush Diagnostic: IO 149 ! + ~~~~~~~~~~~~~~~~~~~~ 150 ! #vu logical su_opn ! IO Switch 151 ! #vu common/SI_qSn_L/su_opn ! 152 153 154 ! +--DATA 155 ! + ==== 156 157 data dzepsi/0.0001/ ! Minim. Snow Layer Thickness (!) 158 ! #?? data dz_Min/0.005/ ! Minim. Snow Layer Thickness 159 ! ... Warning: Too high for Col de Porte: precludes 1st snow (layer) apparition 160 data dz_Min/2.5e-3/ ! Minim. Snow Layer Thickness 161 data SGDmax/0.003/ ! Maxim. Snow Grain Diameter [m] 162 ! ! (Rowe et al. 1995, JGR p.16268) 163 164 ! +--Energy Budget (IN) 165 ! + ================== 166 167 ! #e1 DO ikl=1,knonv 168 ! #e1 EqSn_0(ikl) = 0. 169 ! #e1 END DO 170 ! #e1 DO isn=nsno,1,-1 171 ! #e1 DO ikl=1,knonv 172 ! #e1 EqSn_0(ikl) = EqSn_0(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn) 173 ! #e1. *(Cn_dSV *(TsisSV(ikl,isn) -TfSnow ) 174 ! #e1. -Lf_H2O *(1. -eta_SV(ikl,isn))) 175 ! #e1 END DO 176 ! #e1 END DO 177 178 179 ! +--Water Budget (IN) 180 ! + ================== 181 182 ! #vm DO ikl=1,knonv 183 ! #vm WqSn_0(ikl) = drr_SV(ikl) * dt__SV 184 ! #vm. +rusnSV(ikl) 185 ! #vm END DO 186 ! #vm DO isn=nsno,1,-1 187 ! #vm DO ikl=1,knonv 188 ! #vm WqSn_0(ikl) = WqSn_0(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn) 189 ! #vm END DO 190 ! #vm END DO 191 192 193 ! +--Snow Melt Budget 194 ! + ================ 195 196 ! #m1 DO ikl=1,knonv 197 ! #m1 SImelt(ikl) = 0. 198 ! #m1 SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV 199 ! #m1 END DO 200 201 202 ! +--Initialization 203 ! + ============== 204 205 DO ikl=1,knonv 206 noSnow(ikl) = 0 ! Nb of Layers Updater 207 ispiSV(ikl) = 0 ! Pore Hole Close OFF Index 208 ! ! (assumed to be the Top of 209 ! ! the surimposed Ice Layer) 210 zn5_SV(ikl) = 0. 211 rusnSV0(ikl) = 0. 212 213 END DO 214 215 216 ! +--Melting/Freezing Energy 217 ! + ======================= 218 219 ! +...REMARK: Snow liquid Water Temperature assumed = TfSnow 220 ! + ^^^^^^ 221 DO ikl=1,knonv 222 EExdum(ikl) = drr_SV(ikl) * C__Wat *(TaT_SV(ikl)-TfSnow) & 223 * dt__SV 224 EExcsv(ikl) = EExdum(ikl) * min(1,isnoSV(ikl)) ! Snow exists 225 EExdum(ikl) = EExdum(ikl) - EExcsv(ikl) ! 226 ! #e1 EqSn_d(ikl) = EExcsv(ikl) ! 227 END DO 228 229 230 ! +--Surficial Water Status 231 ! + ---------------------- 232 233 DO ikl=1,knonv 234 SWS_SV(ikl) = max(zero,sign(unun,TfSnow & 235 -TsisSV(ikl,isnoSV(ikl)))) 236 END DO 237 238 DO ikl=1,knonv 239 240 DO isn=min(nsno,isnoSV(ikl)+1),1,-1 241 ! EV DO isn=nsno,1,-1 242 ! +--Energy, store Previous Content 243 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 244 dTSnow = TsisSV(ikl,isn) - TfSnow 245 EExcsv(ikl) = EExcsv(ikl) & 246 + ro__SV(ikl,isn) * Cn_dSV * dTSnow & 247 * dzsnSV(ikl,isn) 248 TsisSV(ikl,isn) = TfSnow 249 250 ! +--Water, store Previous Content 251 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 252 drr_SV(ikl) = drr_SV(ikl) & 253 + ro__SV(ikl,isn) * eta_SV(ikl,isn) & 254 * dzsnSV(ikl,isn) & 255 / dt__SV 256 ro__SV(ikl,isn) = & 257 ro__SV(ikl,isn) *(1. - eta_SV(ikl,isn)) 258 eta_SV(ikl,isn) = 0. 259 260 261 ! +--Melting if EExcsv > 0 262 ! + ====================== 263 264 EnMelt = max(zero, EExcsv(ikl) ) 265 266 ! +--Energy Consumption 267 ! + ^^^^^^^^^^^^^^^^^^ 268 SnHLat = ro__SV(ikl,isn) * Lf_H2O 269 dzMelt(ikl) = EnMelt / max(SnHLat, epsi ) 270 noSnow(ikl) = noSnow(ikl) & 271 + max(zero ,sign(unun,dzMelt(ikl) & ! 272 -dzsnSV(ikl ,isn))) & ! 1 if full Melt 273 *min(1 , max(0 ,1+isnoSV(ikl)-isn)) ! 1 in the Pack 274 dzMelt(ikl) = & 275 min(dzsnSV(ikl, isn),dzMelt(ikl)) 276 dzsnSV(ikl,isn) = & 277 dzsnSV(ikl,isn) -dzMelt(ikl) 278 zn5_SV(ikl) = zn5_SV(ikl) +dzMelt(ikl) 279 EExcsv(ikl) = EExcsv(ikl) -dzMelt(ikl)*SnHLat 280 wem_SV(ikl) = wem_SV(ikl) -dzMelt(ikl)*ro__SV(ikl,isn) 281 282 ! +--Water Production 283 ! + ^^^^^^^^^^^^^^^^^ 284 drr_SV(ikl) = drr_SV(ikl) & 285 + ro__SV(ikl,isn) * dzMelt(ikl)/dt__SV 286 ! #m1 SImelt(ikl) = SImelt(ikl) 287 ! #m1. + ro__SV(ikl,isn) * dzMelt(ikl) 288 OKmelt =max(zero,sign(unun,drr_SV(ikl)-epsi)) 289 290 ! +--Snow History 291 ! + ^^^^^^^^^^^^ 292 k_face = min( istoSV(ikl,isn),istdSV(1)) & ! = 1 if 293 *max(0,2-istoSV(ikl,isn) ) ! faceted 294 istoSV(ikl,isn) = & ! 295 (1.-OKmelt) * istoSV(ikl,isn) & ! 296 + OKmelt *((1-k_face) * istdSV(2) & ! 297 + k_face * istdSV(3) ) ! 298 299 300 ! +--Freezing if EExcsv < 0 301 ! + ====================== 302 303 rdzsno = ro__SV(ikl,isn) * dzsnSV(ikl ,isn) 304 LayrOK = min( 1, max(0 , isnoSV(ikl)-isn+1)) 305 EnFrez = min(zero, EExcsv(ikl)) 306 WaFrez = -( EnFrez * LayrOK / Lf_H2O) 307 drrNEW = max(zero,drr_SV(ikl) - WaFrez / dt__SV) 308 WaFrez = ( drr_SV(ikl) - drrNEW)* dt__SV 309 drr_SV(ikl) = drrNEW 310 EExcsv(ikl) = EExcsv(ikl) + WaFrez * Lf_H2O 311 EnFrez = min(zero,EExcsv(ikl)) * LayrOK 312 rdzNEW = WaFrez + rdzsno 313 ro__SV(ikl,isn) = rdzNEW /max(epsi, dzsnSV(ikl,isn)) 314 TsisSV(ikl,isn) = TfSnow & 315 + EnFrez /(Cn_dSV *max(epsi, rdzNEW) ) 316 EExcsv(ikl) = EExcsv(ikl) - EnFrez 317 wer_SV(ikl) = WaFrez & 318 + wer_SV(ikl) 319 320 321 322 ! +--Snow Water Content 323 ! + ================== 324 325 ! +--Percolation Velocity 326 ! + ^^^^^^^^^^^^^^^^^^^^ 327 ! #PW SGDiam = 1.6d-4 328 ! #PW. + 1.1d-13 *(ro__SV(ikl,isn)*ro__SV(ikl,isn) 329 ! #PW. *ro__SV(ikl,isn)*ro__SV(ikl,isn)) 330 331 ! +--Pore Volume [-] 332 ! + ^^^^^^^^^^^^^^^^^ 333 rosDry =(1. - eta_SV(ikl,isn))* ro__SV(ikl,isn) ! 334 PorVol = 1. - rosDry / ro_Ice ! 335 PorVol = max(PorVol , zero ) ! 336 337 ! +--Water Retention 338 ! + ^^^^^^^^^^^^^^^^ 339 rWater = ws0dSV * PorVol * ro_Wat * dzsnSV(ikl,isn) 340 drrNEW = max(zero,drr_SV(ikl) - rWater /dt__SV) 341 rWater = ( drr_SV(ikl) - drrNEW)*dt__SV 342 drr_SV(ikl) = drrNEW 343 rdzNEW = rWater & 344 + rosDry * dzsnSV(ikl,isn) 345 eta_SV(ikl,isn) = rWater / max(epsi,rdzNEW) 346 ro__SV(ikl,isn) = rdzNEW / max(epsi,dzsnSV(ikl,isn)) 347 348 ! +--Pore Hole Close OFF 349 ! + ^^^^^^^^^^^^^^^^^^^ 350 PClose = max(zero, & 351 sign(unun,ro__SV(ikl,isn) & 352 -roCdSV )) 353 ispiSV(ikl) = ispiSV(ikl) *(1.-PClose) & 354 + max(ispiSV(ikl),isn) * Pclose 355 PClose = max(0 , & ! Water under SuPer.Ice 356 min (1 ,ispiSV(ikl) & ! contributes to 357 -isn )) ! Surficial Water 358 359 !XF 360 if(ro__SV(ikl,isn) >= roCdSV.and.ro__SV(ikl,1)<900) & 361 PClose = min(0.50,PClose * & 362 (1.-(ro_ice-ro__SV(ikl,isn))/(ro_ice-roCdSV))) 363 364 PClose = max(0.,min(1.,PClose)) 365 366 if(isn==1) then 367 PClose = 1 368 ispiSV(ikl)= max(ispiSV(ikl),1) 369 endif 370 371 if(drr_SV(ikl) >0 .and.TsisSV(ikl,isn)>273.14) then 372 if((ro__SV(ikl,isn)>900.and.ro__SV(ikl,isn)<920).or. & 373 ro__SV(ikl,isn)>950) then 374 dzsnSV(ikl,isn) = dzsnSV(ikl,isn)*ro__SV(ikl,isn)/ro_ice 375 ro__SV(ikl,isn) = ro_ice 376 PClose = 1 377 endif 378 endif 379 380 ! if (isn>1.and.isn<nsno .and. 381 ! . ro__SV(ikl,isn-1)>900 .and. 382 ! . ro__SV(ikl,isn) >roCdSV .and. 383 ! . ro__SV(ikl,isn) <900 .and. 384 ! . TsisSV(ikl,isn) >273.14 .and. 385 ! . TsisSV(ikl,isn+1)<273.15 .and. 386 ! . drr_SV(ikl) >0) then 387 ! TsisSV(ikl,isn)=273.14 388 ! PClose = 1 389 ! endif 390 391 !XF 392 rusnSV(ikl) = rusnSV(ikl) & 393 + drr_SV(ikl) *dt__SV * PClose 394 rusnSV0(ikl)= rusnSV0(ikl) & 395 + drr_SV(ikl) *dt__SV * PClose 396 drr_SV(ikl) = drr_SV(ikl) *(1.-PClose) 397 398 END DO 399 400 END DO 401 402 403 ! +--Remove Zero-Thickness Layers 404 ! + ============================ 405 406 1000 CONTINUE 407 isnitr = 0 408 DO ikl=1,knonv 409 isnUpD = 0 410 isinew = 0 411 !XF 412 413 414 DO isn=1,min(nsno-1,isnoSV(ikl)) 415 isnnew =(unun-max(zero ,sign(unun,dzsnSV(ikl,isn)-dzepsi))) & 416 * max(0 , min(1 ,isnoSV(ikl) +1 -isn )) 417 isnUpD = max(isnUpD, isnnew) 418 isnitr = max(isnitr, isnnew) 419 isinew = isn*isnUpD *max(0, 1-isinew) & ! LowerMost 0-Layer 420 +isinew ! Index 421 dzsnSV(ikl,isn) = dzsnSV(ikl,isn+isnnew) 422 ro__SV(ikl,isn) = ro__SV(ikl,isn+isnnew) 423 TsisSV(ikl,isn) = TsisSV(ikl,isn+isnnew) 424 eta_SV(ikl,isn) = eta_SV(ikl,isn+isnnew) 425 G1snSV(ikl,isn) = G1snSV(ikl,isn+isnnew) 426 G2snSV(ikl,isn) = G2snSV(ikl,isn+isnnew) 427 dzsnSV(ikl,isn+isnnew) =(1-isnnew)*dzsnSV(ikl,isn+isnnew) 428 ro__SV(ikl,isn+isnnew) =(1-isnnew)*ro__SV(ikl,isn+isnnew) 429 eta_SV(ikl,isn+isnnew) =(1-isnnew)*eta_SV(ikl,isn+isnnew) 430 G1snSV(ikl,isn+isnnew) =(1-isnnew)*G1snSV(ikl,isn+isnnew) 431 G2snSV(ikl,isn+isnnew) =(1-isnnew)*G2snSV(ikl,isn+isnnew) 432 433 END DO 434 isnoSV(ikl) = isnoSV(ikl)-isnUpD ! Nb of Snow Layer 435 ispiSV(ikl) = ispiSV(ikl) & ! Nb of SuperI Layer 436 -isnUpD *max(0,min(ispiSV(ikl)-isinew,1)) ! Update if I=0 437 438 END DO 439 440 IF (isnitr.GT.0) GO TO 1000 441 442 443 ! +--New upper Limit of the non erodible Snow (istoSV .GT. 1) 444 ! + ======================================== 445 446 DO ikl=1,knonv 447 nh = 0 448 !XF 449 DO isn= isnoSV(ikl),1,-1 450 nh = nh + isn* min(istoSV(ikl,isn)-1,1)*max(0,1-nh) 451 ENDDO 452 zc = 0. 453 zt = 0. 454 !XF 455 DO isn=1,isnoSV(ikl) 456 zc = zc + dzsnSV(ikl,isn) *ro__SV(ikl,isn) & 457 * max(0,min(1,nh+1-isn)) 458 zt = zt + dzsnSV(ikl,isn) *ro__SV(ikl,isn) 459 END DO 460 zWE_SV(ikl) = zt 461 zWEcSV(ikl) = min(zWEcSV(ikl),zt) 462 zWEcSV(ikl) = max(zWEcSV(ikl),zc) 463 END DO 464 465 466 ! +--Energy Budget (OUT) 467 ! + =================== 468 469 ! #vm DO ikl=1,knonv 470 ! #vm EqSn01(ikl) =-EqSn_0(ikl) 471 ! #vm. -EExcsv(ikl) 472 ! #vm END DO 473 ! #vm DO isn=nsno,1,-1 474 ! #vm DO ikl=1,knonv 475 ! #vm EqSn01(ikl) = EqSn01(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn) 476 ! #vm. *(Cn_dSV *(TsisSV(ikl,isn) -TfSnow ) 477 ! #vm. -Lf_H2O *(1. -eta_SV(ikl,isn))) 478 ! #vm END DO 479 ! #vm END DO 480 481 482 ! +--"Negative Heat" from supercooled rain 483 ! + ------------------------------------ 484 485 DO ikl=1,knonv 486 EExcsv(ikl) = EExcsv(ikl) + EExdum(ikl) 487 488 489 ! +--Surficial Water Run OFF 490 ! + ----------------------- 491 492 rusnew = rusnSV(ikl) * SWf_SV(ikl) 493 494 if(isnoSV(ikl)<=1 .OR. opt_runoff_ac) rusnew = 0. 495 ! !if(ivgtSV(ikl)>=1) rusnew = 0. 496 497 ! #EU rusnew = 0. 498 ! #AC rusnew = 0. 499 500 RnofSV(ikl) = RnofSV(ikl) & 501 +(rusnSV(ikl) - rusnew ) / dt__SV 502 RuofSV(ikl,1) = RuofSV(ikl,1) & 503 +(rusnSV(ikl) - rusnew ) / dt__SV 504 RuofSV(ikl,4) = RuofSV(ikl,4) & 505 +(rusnSV0(ikl) ) / dt__SV 506 rusnSV(ikl) = rusnew 507 END DO 508 509 510 ! +--Percolation down the Continental Ice Pack 511 ! + ----------------------------------------- 512 513 DO ikl=1,knonv 514 drr_SV(ikl) = drr_SV(ikl) + rusnSV(ikl) & 515 * (1-min(1,ispiSV(ikl)))/ dt__SV 516 rusnSV(ikl) = rusnSV(ikl) & 517 * min(1,ispiSV(ikl)) 518 END DO 519 520 !XF removal of too thin snowlayers if TT> 275.15 + bug if TT>> 273.15 521 DO ikl=1,knonv 522 zt=0. 523 DO isn=1,isnoSV(ikl) 524 zt=zt+dzsnSV(ikl,isn) 525 ENDDO 526 527 if(zt<0.005+(TaT_SV(ikl)-TfSnow)/1000..and. & 528 isnoSV(ikl) >0 .and. & 529 TaT_SV(ikl) >=TfSnow .and. & 530 istoSV(ikl,isnoSV(ikl)) >1 ) then 531 DO isn=1,isnoSV(ikl) 532 drr_SV(ikl) = drr_SV(ikl) & 533 + dzsnSV(ikl,isn)*ro__SV(ikl,isn) /dt__SV 534 dzsnSV(ikl,isn)= 0. 535 536 ENDDO 537 isnoSV(ikl) = 0 538 endif 539 ENDDO 540 541 ! +--Slush Formation (Activated. CAUTION: ADD RunOff Possibility before Activation) 542 ! + --------------- ^^^^^^^ ^^^ 543 544 IF (is_ok_slush) THEN 545 546 DO ikl=1,knonv 547 DO isn=1,isnoSV(ikl) 548 kSlush = min(1,max(0,isn+1-ispiSV(ikl))) ! Slush Switch 549 550 ! +--Available Additional Pore Volume [-] 551 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 552 PorVol = 1. - ro__SV(ikl,isn) & ! [--] 553 *(1. - eta_SV(ikl,isn))/ ro_Ice & ! 554 - eta_SV(ikl,isn) & ! 555 *ro__SV(ikl,isn) / ro_Wat ! 556 PorVol = max(PorVol , zero ) ! 557 zWater = dzsnSV(ikl,isn) * PorVol * 1000. & ! [mm] OR [kg/m2] 558 * (1. -SWS_SV(ikl) & ! 0 <=> freezing 559 *(1 -min(1,iabs(isn-isnoSV(ikl))))) ! 1 <=> isn=isnoSV 560 zSlush = min(rusnSV(ikl) , zWater) ! [mm] OR [kg/m2] 561 ro_new =(dzsnSV(ikl,isn) * ro__SV(ikl,isn) & ! 562 +zSlush ) & ! 563 / max(dzsnSV(ikl,isn) , epsi ) ! 564 if(ro_new<ro_Ice+20) then ! MAX 940kg/m3 ! 565 rusnSV(ikl) = rusnSV(ikl) - zSlush ! [mm] OR [kg/m2] 566 RuofSV(ikl,4)= max(0.,RuofSV(ikl,4) - zSlush/dt__SV) 567 eta_SV(ikl,isn) =(ro_new - ro__SV(ikl,isn) & ! 568 *(1. - eta_SV(ikl,isn))) & ! 569 / max (ro_new , epsi ) ! 570 ro__SV(ikl,isn) = ro_new ! 571 endif 572 END DO 573 END DO 574 END IF 575 576 ! +--Impact of the Sublimation/Deposition on the Surface Mass Balance 577 ! + ================================================================ 578 579 DO ikl=1,knonv 580 isn = isnoSV(ikl) 581 dzVap0 = dt__SV & 582 * HLs_sv(ikl) * min(isn , 1 ) & 583 /(Lx_H2O(ikl) * max(ro__SV(ikl,isn) , epsi)) 584 NOLayr=min(zero,sign(unun,dzsnSV(ikl,isn) + dzVap0)) 585 dzVap1=min(zero, dzsnSV(ikl,isn) + dzVap0) 586 587 588 ! +--Additional Energy 589 ! + ----------------- 590 591 ! #VH AdEnrg = dzVap0 * ro__SV(ikl,isnoSV(ikl)) ! Water Vapor 592 ! #VH. *C__Wat *(TsisSV(ikl,isnoSV(ikl)) -TfSnow) ! Sensible Heat 593 594 ! #aH B_Enrg =(Cn_dSV *(TsisSV(ikl,isn) -TfSnow ) 595 ! #aH. -Lf_H2O *(1. -eta_SV(ikl,isn))) 596 ! #aH. /(1. + dzVap0 /max(epsi,dzsnSV(ikl,isn))) 597 ! #aH eta_SV(ikl,isn) = 598 ! #aH. max(zero,unun +(B_Enrg 599 ! #aH. -(TsisSV(ikl,isn) -TfSnow)*Cn_dSV) 600 ! #aH. /Lf_H2O ) 601 ! #aH TsisSV(ikl,isn) = ( B_Enrg 602 ! #aH. +(1. -eta_SV(ikl,isn)) 603 ! #aH. *Lf_H2O ) 604 ! #aH. / Cn_dSV 605 ! #aH. + TfSnow 606 607 ! #e1 STOP "PLEASE add Energy (#aH) from deposition/sublimation" 608 609 610 ! +--Update of the upper Snow layer Thickness 611 ! + ---------------------------------------- 612 613 dzsnSV(ikl,isn) = & 614 max(zero, dzsnSV(ikl,isnoSV(ikl)) + dzVap0) 615 isnoSV(ikl) = isnoSV(ikl) + NOLayr 616 isn = isnoSV(ikl) 617 dzsnSV(ikl,isn) = dzsnSV(ikl,isn) + dzVap1 618 wes_SV(ikl) = ro__SV(ikl,isn) * dzVap0 619 620 END DO 621 622 623 ! +--Energy Budget (OUT) 624 ! + =================== 625 626 ! #vm DO ikl=1,knonv 627 ! #vm EqSn02(ikl) =-EqSn_0(ikl) 628 ! #vm. -EExcsv(ikl) 629 ! #vm END DO 630 ! #vm DO isn=nsno,1,-1 631 ! #vm DO ikl=1,knonv 632 ! #vm EqSn02(ikl) = EqSn01(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn) 633 ! #vm. *(Cn_dSV *(TsisSV(ikl,isn) -TfSnow ) 634 ! #vm. -Lf_H2O *(1. -eta_SV(ikl,isn))) 635 ! #vm END DO 636 ! #vm END DO 637 638 639 ! +--Snow/I Budget 640 ! + ------------- 641 642 ! #m1 DO ikl=1,knonv 643 ! #m1 SIsubl(ikl) = dt__SV*HLs_sv(ikl)*min(isnoSV(ikl),1) 644 ! #m1. /Lx_H2O(ikl) 645 ! #m1 SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV 646 ! #m1. - SIrnof(ikl) 647 ! #m1 END DO 648 649 650 ! +--Anticipated Disappearance of a rapidly Melting too thin Last Snow Layer 651 ! + ======================================================================= 652 653 DO ikl=1,knonv 654 LastOK = min(1 , max(0 ,iiceSV(ikl)-isnoSV(ikl)+2) & 655 *min(1 ,isnoSV(ikl)-iiceSV(ikl)) & 656 +min(1 ,isnoSV(ikl)) ) 657 RapdOK = max(zero,sign(unun,dzMelt(ikl)-epsi )) 658 ThinOK = max(zero,sign(unun,dz_Min -dzsnSV(ikl,1))) 659 z_Melt = LastOK *RapdOK*ThinOK 660 noSnow(ikl) = noSnow(ikl) + z_Melt 661 z_Melt = z_Melt *dzsnSV(ikl,1) 662 dzsnSV(ikl,1) = dzsnSV(ikl,1) - z_Melt 663 EExcsv(ikl) = EExcsv(ikl) - z_Melt *ro__SV(ikl,1) & 664 *(1. -eta_SV(ikl,1))*Lf_H2O 665 666 ! +--Water Production 667 ! + ^^^^^^^^^^^^^^^^^ 668 drr_SV(ikl) = drr_SV(ikl) & 669 + ro__SV(ikl,1) * z_Melt /dt__SV 670 END DO 671 672 673 ! +--Update Nb of Layers 674 ! + =================== 675 676 DO ikl=1,knonv 677 isnoSV(ikl) = isnoSV(ikl) & 678 * min(1,iabs(isnoSV(ikl)-noSnow(ikl))) 679 END DO 680 681 682 ! Energy Budget (OUT) 683 ! =================== 684 685 ! #e1 DO ikl=1,knonv 686 ! #e1 EqSn_1(ikl) = 0. 687 ! #e1 END DO 688 ! #e1 DO isn=nsno,1,-1 689 ! #e1 DO ikl=1,knonv 690 ! #e1 EqSn_1(ikl) = EqSn_1(ikl) + ro__SV(ikl,isn) *dzsnSV(ikl,isn) 691 ! #e1. *(Cn_dSV *(TsisSV(ikl,isn) -TfSnow ) 692 ! #e1. -Lf_H2O *(1. -eta_SV(ikl,isn))) 693 ! #e1 END DO 694 ! #e1 END DO 695 696 697 ! +--Water Budget (OUT) 698 ! + =================== 699 700 ! #vm DO ikl=1,knonv 701 ! #vm WqSn_0(ikl) = WqSn_0(ikl) 702 ! #vm. + HLs_sv(ikl) * dt__SV 703 ! #vm. *min(isnoSV(ikl),1) / Lx_H2O(ikl) 704 ! #vm WqSn_1(ikl) = drr_SV(ikl) * dt__SV 705 ! #vm. + rusnSV(ikl) 706 ! #vm. + RnofSV(ikl) * dt__SV 707 ! #vm END DO 708 ! #vm DO isn=nsno,1,-1 709 ! #vm DO ikl=1,knonv 710 ! #vm WqSn_1(ikl) = WqSn_1(ikl) 711 ! #vm. + ro__SV(ikl,isn)* dzsnSV(ikl,isn) 712 ! #vm END DO 713 ! #vm END DO 714 715 716 return 717 end subroutine sisvat_qsn -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_qso.f90
r5245 r5246 1 2 3 4 ! #m0. (Wats_0,Wats_1,Wats_d)5 6 C+------------------------------------------------------------------------+7 C| MAR SISVAT_qSo 6-04-2001 MAR |8 C| SubRoutine SISVAT_qSo computes the Soil Water Balance |9 C+------------------------------------------------------------------------+10 C| |11 C| PARAMETERS: knonv: Total Number of columns = |12 C| ^^^^^^^^^^ = Total Number of continental grid boxes |13 C| X Number of Mosaic Cell per grid box |14 C| |15 C| INPUT: isnoSV = total Nb of Ice/Snow Layers |16 C| ^^^^^ isotSV = 0,...,11: Soil Type |17 C| 0: Water, Solid or Liquid |18 C| |19 C| INPUT: rhT_SV : SBL Top Air Density [kg/m3] |20 C| ^^^^^ drr_SV : Rain Intensity [kg/m2/s] |21 C| LSdzsv : Vertical Discretization Factor [-] |22 C| = 1. Soil |23 C| = 1000. Ocean |24 C| dt__SV : Time Step [s] |25 C| |26 C| Lx_H2O : Latent Heat of Vaporization/Sublimation [J/kg] |27 C| HLs_sv : Latent Heat Flux [W/m2] |28 C| |29 C| INPUT / eta_SV : Water Content [m3/m3] |30 C| OUTPUT: Khydsv : Soil Hydraulic Conductivity [m/s] |31 C| ^^^^^^ |32 C| |33 C| OUTPUT: RnofSV : RunOFF Intensity [kg/m2/s] |34 C| ^^^^^^ Wats_0 : Soil Water, before Forcing [mm] |35 C| Wats_1 : Soil Water, after Forcing [mm] |36 C| Wats_d : Soil Water Forcing [mm] |37 C| |38 C| Internal Variables: |39 C| ^^^^^^^^^^^^^^^^^^ |40 C| z_Bump : (Partly)Bumpy Layers Height [m] |41 C| z0Bump : Bumpy Layers Height [m] |42 C| dzBump : Lowest Bumpy Layer: [m] |43 C| etBump : Bumps Layer Averaged Humidity [m3/m3] |44 C| etaMid : Layer Interface's Humidity [m3/m3] |45 C| eta__f : Layer Humidity (Water Front)[m3/m3] |46 C| Dhyd_f : Soil Hydraulic Diffusivity (Water Front) [m2/s] |47 C| Dhydif : Soil Hydraulic Diffusivity [m2/s] |48 C| WgFlow : Water gravitational Flux [kg/m2/s] |49 C| Wg_MAX : Water MAXIMUM gravitational Flux [kg/m2/s] |50 C| SatRat : Water Saturation Flux [kg/m2/s] |51 C| WExces : Water Saturation Excess Flux [kg/m2/s] |52 C| Dhydtz : Dhydif * dt / dz [m] |53 C| FreeDr : Free Drainage Fraction [-] |54 C| Elem_A : A Diagonal Coefficient |55 C| Elem_C : C Diagonal Coefficient |56 C| Diag_A : A Diagonal |57 C| Diag_B : B Diagonal |58 C| Diag_C : C Diagonal |59 C| Term_D : Independant Term |60 C| Aux__P : P Auxiliary Variable |61 C| Aux__Q : Q Auxiliary Variable |62 C| |63 C| TUNING PARAMETER: |64 C| ^^^^^^^^^^^^^^^^ |65 C| z0soil : Soil Surface averaged Bumps Height [m] |66 C| |67 C| METHOD: NO Skin Surface Humidity |68 C| ^^^^^^ Semi-Implicit Crank Nicholson Scheme |69 C| (Partial) free Drainage, Water Bodies excepted (Lakes, Sea) |70 C| |71 72 C| |73 C| # OPTIONS: #GF: Saturation Front |74 C| # ^^^^^^^ #GH: Saturation Front allows Horton Runoff |75 C| # #GA: Soil Humidity Geometric Average |76 C| # #BP: Parameterization of Terrain Bumps |77 C| |78 C| |79 C+------------------------------------------------------------------------+80 81 82 83 84 C+--Global Variables85 C+ ================86 87 88 89 90 91 92 93 94 95 96 97 98 C+--OUTPUT99 C+ ------100 101 ! Water (Mass) Budget102 ! ~~~~~~~~~~~~~~~~~~~103 ! #m0 real Wats_0(knonv) ! Soil Water, before forcing104 ! #m0 real Wats_1(knonv) ! Soil Water, after forcing105 ! #m0 real Wats_d(knonv) ! Soil Water forcing106 107 108 C+--Internal Variables109 C+ ==================110 111 integerisl ,jsl ,ist ,ikl !112 integerikm ,ikp ,ik0 ,ik1 !113 integerist__s,ist__w ! Soil/Water Body Identifier114 c#BP real z0soil ! Soil Surface Bumps Height [m]115 c#BP real z_Bump !(Partly)Bumpy Layers Height [m]116 c#BP real z0Bump ! Bumpy Layers Height [m]117 c#BP real dzBump ! Lowest Bumpy Layer:118 119 c#BP real etBump(knonv) ! Bumps Layer Averaged Humidity120 realetaMid ! Layer Interface's Humidity121 realDhydif ! Hydraulic Diffusivity [m2/s]122 realeta__f ! Water Front Soil Water Content123 realKhyd_f ! Water Front Hydraulic Conduct.124 realKhydav ! Hydraulic Conductivity [m/s]125 realWgFlow ! Water gravitat. Flux [kg/m2/s]126 realWg_MAX ! Water MAX.grav. Flux [kg/m2/s]127 realSatRat ! Saturation Flux [kg/m2/s]128 realWExces ! Saturat. Excess Flux [kg/m2/s]129 realSoRnOF(knonv) ! Soil Run OFF130 realDhydtz(knonv,-nsol:0) ! Dhydif * dt / dz [m]131 realElem_A,Elem_B,Elem_C ! Diagonal Coefficients132 realDiag_A(knonv,-nsol:0) ! A Diagonal133 realDiag_B(knonv,-nsol:0) ! B Diagonal134 realDiag_C(knonv,-nsol:0) ! C Diagonal135 realTerm_D(knonv,-nsol:0) ! Independant Term136 realAux__P(knonv,-nsol:0) ! P Auxiliary Variable137 realAux__Q(knonv,-nsol:0) ! Q Auxiliary Variable138 realetaaux(knonv,-nsol:-nsol+1) ! Soil Water Content [m3/m3]139 realFreeDr ! Free Drainage Fraction (actual)140 realFreeD0 ! Free Drainage Fraction (1=Full)141 realaKdtSV3( 0:nsot, 0:nkhy) ! Khyd=a*eta+b: a * dt142 realbKdtSV3( 0:nsot, 0:nkhy) ! Khyd=a*eta+b: b * dt143 144 ! Water (Mass) Budget145 ! ~~~~~~~~~~~~~~~~~~~146 c#mw logical mwopen ! IO Switch147 c#mw common/Sm_qSo_L/mwopen !148 c#mw real hourwr,timewr !149 c#mw common/Sm_qSo_R/timewr !150 c#mw real Evapor(knonv) !151 152 153 C+--Internal DATA154 C+ =============155 156 c#BP data z0soil/0.020/ ! Soil Surface Bumps Height [m]157 158 159 160 161 162 ! Water Budget (IN)163 ! ==================164 165 ! #m0 DO ikl=1,knonv166 ! #m0 Wats_0(ikl) = 0. ! OLD RunOFF Contrib.167 ! #m0 Wats_d(ikl) = drr_SV(ikl) ! Water Surface Forc.168 ! #m0 END DO169 170 ! #m0 isl= -nsol171 ! #m0 DO ikl=1,knonv172 ! #m0 Wats_0(ikl) = Wats_0(ikl)173 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz78SV(isl)174 ! #m0. + eta_SV(ikl,isl+1) *dz_8SV(isl) ) * LSdzsv(ikl)175 ! #m0 END DO176 177 ! #m0 DO isl= -nsol+1,-1178 ! #m0 DO ikl=1,knonv179 ! #m0 Wats_0(ikl) = Wats_0(ikl)180 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz34SV(isl)181 ! #m0. +(eta_SV(ikl,isl-1)182 ! #m0. +eta_SV(ikl,isl+1))*dz_8SV(isl) ) * LSdzsv(ikl)183 ! #m0 END DO184 ! #m0 END DO185 186 ! #m0 isl= 0187 ! #m0 DO ikl=1,knonv188 ! #m0 Wats_0(ikl) = Wats_0(ikl)189 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz78SV(isl)190 ! #m0. + eta_SV(ikl,isl-1) *dz_8SV(isl) ) * LSdzsv(ikl)191 ! #m0 END DO192 193 194 C+--Gravitational Flow195 C+ ==================196 197 C+... METHOD: Surface Water Flux saturates successively the soil layers198 C+ ^^^^^^ from up to below, but is limited by infiltration capacity.199 C+ Hydraulic Conductivity again contributes after this step,200 C+ not redundantly because of a constant (saturated) profile.201 202 C+--Flux Limitor203 C+ ^^^^^^^^^^^^^204 205 206 207 208 209 Dhydif = s1__SV(ist)210 . *max(epsi,eta_SV(ikl,isl))! Hydraulic Diffusivity211 .**(bCHdSV(ist)+2.) ! DR97, Eqn.(3.36)212 Dhydif = ist__s * Dhydif!213 .+ ist__w * vK_dSV ! Water Bodies214 C+215 Khydav = ist__s * Ks_dSV(ist)! DR97 Assumption216 .+ ist__w * vK_dSV ! Water Bodies217 C+218 Wg_MAX = ro_Wat *Dhydif! MAXimum Infiltration219 . *(etadSV(ist)-eta_SV(ikl,isl))! Rate220 . /(dzAvSV(isl)*LSdzsv(ikl) )!221 .+ ro_Wat *Khydav !222 223 C+--Surface Horton RunOFF224 C+ ^^^^^^^^^^^^^^^^^^^^^225 SoRnOF(ikl) =226 .max(zero,drr_SV(ikl)-Wg_MAX)227 228 229 230 231 232 c#GF DO isl=0,-nsol,-1233 c#GF DO ikl=1,knonv234 c#GF ist = isotSV(ikl) ! Soil Type235 c#GF ist__s = min(ist, 1) ! 1 => Soil236 c#GF ist__w = 1 - ist__s ! 1 => Water Body237 238 C+--Water Diffusion239 C+ ^^^^^^^^^^^^^^^240 c#GF Dhydif = s1__SV(ist)241 c#GF. *max(epsi,eta_SV(ikl,isl)) ! Hydraulic Diffusivity242 c#GF. **(bCHdSV(ist)+2.) ! DR97, Eqn.(3.36)243 c#GF Dhydif = ist__s * Dhydif !244 c#GF. + ist__w * vK_dSV ! Water Bodies245 246 C+--Water Conduction (without Horton Runoff)247 C+ ^^^^^^^^^^^^^^^^248 c#GF Khyd_f = Ks_dSV(ist)249 C+... Uses saturated K ==> Horton Runoff ~0 !250 251 C+--Water Conduction (with Horton Runoff)252 C+ ^^^^^^^^^^^^^^^^253 c#GH ik0 = nkhy *eta_SV(ikl,isl)254 c#GH. /etadSV(ist)255 c#GH eta__f = 1.256 c#GH. -aKdtSV3(ist,ik0)/(2. *dzAvSV(isl)257 c#GH. *LSdzsv(ikl))258 c#GH eta__f = max(eps_21,eta__f)259 c#GH eta__f = min(etadSV(ist),260 c#GH. eta_SV(ikl,isl) +261 c#GH. (aKdtSV3(ist,ik0) *eta_SV(ikl,isl)262 c#GH. +bKdtSV3(ist,ik0)) /(dzAvSV(isl)263 c#GH. *LSdzsv(ikl))264 c#GH. / eta__f )265 c#GH eta__f = .5*(eta_SV(ikl,isl)266 c#GH. +eta__f)267 268 c#gh eta__f = eta_SV(ikl,isl)269 270 c#GH ik0 = nkhy *eta__f271 c#GH. /etadSV(ist)272 c#GH Khyd_f =273 c#GH. (aKdtSV3(ist,ik0) *eta__f274 c#GH. +bKdtSV3(ist,ik0)) /dt__SV275 276 c#GF Khydav = ist__s * Khyd_f ! DR97 Assumption277 c#GF. + ist__w * vK_dSV ! Water Bodies278 279 C+--Gravitational Flow280 C+ ^^^^^^^^^^^^^^^^^^281 c#GF Wg_MAX = ! MAXimum Infiltration282 c#GF. ro_Wat *Dhydif ! Rate283 c#GF. *(etadSV(ist)-eta_SV(ikl,isl)) !284 c#GF. /(dzAvSV(isl)*LSdzsv(ikl) ) !285 c#GF. + ro_Wat *Khydav !286 c#GF END DO287 c#GF END DO288 c#GF DO ikl=1,knonv289 c#GF SoRnOF(ikl) = SoRnOF(ikl) ! RunOFF Intensity290 c#GF. + drr_SV(ikl) ! [kg/m2/s]291 C+!!! Inclure la possibilite de creer une mare sur un bedrock impermeable292 c#GF drr_SV(ikl) = 0.293 c#GF END DO294 295 296 C+--Temperature Correction due to a changed Soil Energy Content297 C+ ===========================================================298 299 C+!!! Mettre en oeuvre le couplage humidit?-?nergie300 301 302 C+--Full Resolution of the Richard's Equation303 C+ =========================================304 305 C+... METHOD: Water content evolution results from water fluxes306 C+ ^^^^^^ at the layer boundaries307 C+ Conductivity is approximated by a piecewise linear profile.308 C+ Semi-Implicit Crank-Nicholson scheme is used.309 C+ (Bruen, 1997, Sensitivity of hydrological processes310 C+ at the land-atmosphere interface.311 C+ Proc. Royal Irish Academy, IGBP symposium312 C+ on global change and the Irish Environment.313 C+ Publ.: Maynooth)314 315 C+ - - - - - - - - isl+1/2 - - ^316 C+ |317 C+ eta_SV(isl) --------------- isl ----- +--dz_dSV(isl) ^318 C+ | |319 C+ Dhydtz(isl) etaMid - - - - - - - - isl-1/2 - - v dzmiSV(isl)--+320 C+ |321 C+ eta_SV(isl-1) --------------- isl-1 ----- v322 323 C+--Transfert Coefficients324 C+ ----------------------------325 326 327 328 329 330 331 etaMid = (dz_dSV(isl) *eta_SV(ikl,isl-1)! eta at layers332 . +dz_dSV(isl-1)*eta_SV(ikl,isl) )! interface333 ./(2.0* dzmiSV(isl)) ! LSdzsv implicit !334 c#GA etaMid = sqrt(dz_dSV(isl) *eta_SV(ikl,isl-1) ! Idem, geometric335 c#GA. *dz_dSV(isl-1)*eta_SV(ikl,isl) ) ! average336 c#GA. /(2.0* dzmiSV(isl)) ! (Vauclin&al.1979)337 Dhydif = s1__SV(ist)! Hydraul.Diffusi.338 .*(etaMid **( bCHdSV(ist)+2.)) ! DR97, Eqn.(3.36)339 Dhydtz(ikl,isl) = Dhydif*dt__SV!340 . /(dzmiSV(isl)!341 .*LSdzsv(ikl)) !342 Dhydtz(ikl,isl) = Dhydtz(ikl,isl) * ist__s! Soil343 .+0.5*dzmiSV(isl)*LSdzsv(ikl) * ist__w ! Water bodies344 345 346 347 348 349 350 351 352 353 C+--Tridiagonal Elimination: Set Up354 C+ -------------------------------355 356 C+--Soil/Snow Interior357 C+ ^^^^^^^^^^^^^^^^^^358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 print *,"CRASH1 in sisvat_qso.f on pixel (i,j,n)",381 .ii__SV(ikl),jj__SV(ikl),nn__SV(ikl)382 print *,"decrease your time step or increase ntphys "//383 ."and ntdiff in time_steps.f"384 385 386 387 388 Elem_A = Dhydtz(ikl,isl)389 .- aKdtSV3(ist,ikm)* dziiSV(isl) *LSdzsv(ikl)390 Elem_B = - (Dhydtz(ikl,isl)391 . +Dhydtz(ikl,isl+1)392 . -aKdtSV3(ist,ik0)*(dziiSV(isl+1)393 .-dzi_SV(isl) )*LSdzsv(ikl))394 Elem_C = Dhydtz(ikl,isl+1)395 .+ aKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl)396 Diag_A(ikl,isl) = dz_8SV(isl) *LSdzsv(ikl)397 .-Implic * Elem_A398 Diag_B(ikl,isl) = dz34SV(isl) *LSdzsv(ikl)399 .-Implic * Elem_B400 Diag_C(ikl,isl) = dz_8SV(isl) *LSdzsv(ikl)401 .-Implic * Elem_C402 403 Term_D(ikl,isl) = (dz_8SV(isl) *LSdzsv(ikl)404 . +Explic *Elem_A )*eta_SV(ikl,isl-1)405 . + (dz34SV(isl) *LSdzsv(ikl)406 . +Explic *Elem_B )*eta_SV(ikl,isl)407 . + (dz_8SV(isl) *LSdzsv(ikl)408 . +Explic *Elem_C )*eta_SV(ikl,isl+1)409 . + (bKdtSV3(ist,ikp)* dzi_SV(isl+1)410 . +bKdtSV3(ist,ik0)*(dziiSV(isl+1)411 . -dzi_SV(isl) )412 . -bKdtSV3(ist,ikm)* dziiSV(isl) )413 .* LSdzsv(ikl)414 415 416 417 418 419 420 c# FreeDr = FreeD0 * min(ist,1)421 422 423 424 425 426 print *,"CRASH2 in sisvat_qso.f on pixel (i,j,n)",427 .ii__SV(ikl),jj__SV(ikl),nn__SV(ikl)428 print *,"decrease your time step or increase ntphys "//429 ."and ntdiff in time_steps.f"430 431 432 433 434 Elem_B = - (Dhydtz(ikl,isl+1)435 . -aKdtSV3(ist,ik0)*(dziiSV(isl+1)*LSdzsv(ikl)436 .-FreeDr ))437 Elem_C = Dhydtz(ikl,isl+1)438 .+ aKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl)439 440 Diag_B(ikl,isl) = dz78SV(isl) *LSdzsv(ikl)441 .-Implic *Elem_B442 Diag_C(ikl,isl) = dz_8SV(isl) *LSdzsv(ikl)443 .-Implic *Elem_C444 445 Term_D(ikl,isl) = (dz78SV(isl) *LSdzsv(ikl)446 . +Explic *Elem_B )*eta_SV(ikl,isl)447 . + (dz_8SV(isl) *LSdzsv(ikl)448 . +Explic *Elem_C )*eta_SV(ikl,isl+1)449 . + (bKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl)450 . +bKdtSV3(ist,ik0)*(dziiSV(isl+1)*LSdzsv(ikl)451 .-FreeDr ))452 453 454 455 456 457 458 459 Elem_A = Dhydtz(ikl,isl)460 .- aKdtSV3(ist,ikm)* dziiSV(isl)*LSdzsv(ikl)461 Elem_B = - (Dhydtz(ikl,isl)462 .+aKdtSV3(ist,ik0)* dzi_SV(isl)*LSdzsv(ikl))463 464 Diag_A(ikl,isl) = dz_8SV(isl) *LSdzsv(ikl)465 .- Implic *Elem_A466 Diag_B(ikl,isl) = dz78SV(isl) *LSdzsv(ikl)467 .- Implic *Elem_B468 469 C+470 Term_D(ikl,isl) = (dz_8SV(isl) *LSdzsv(ikl)471 . +Explic *Elem_A )*eta_SV(ikl,isl-1)472 . + (dz78SV(isl) *LSdzsv(ikl)473 . +Explic *Elem_B )*eta_SV(ikl,isl)474 . - (bKdtSV3(ist,ik0)* dzi_SV(isl)475 . +bKdtSV3(ist,ikm)* dziiSV(isl))*LSdzsv(ikl)476 . + dt__SV *(HLs_sv(ikl) * (1-min(1,isnoSV(ikl)))477 . / (ro_Wat *dz_dSV(0) * Lx_H2O(ikl))478 cXF bug 17/05/2017479 .+drr_SV(ikl))/ro_Wat480 481 482 483 484 485 486 C+487 C+488 C+--Tridiagonal Elimination489 C+ =======================490 C+491 C+--Forward Sweep492 C+ ^^^^^^^^^^^^^^493 494 495 496 497 C+498 499 500 Aux__P(ikl,isl) = Diag_A(ikl,isl) *Aux__Q(ikl,isl-1)501 .+Diag_B(ikl,isl)502 503 504 505 C+506 507 508 509 C+510 511 512 eta_SV(ikl,isl) =(Term_D(ikl,isl)513 . -Diag_A(ikl,isl) *eta_SV(ikl,isl-1))514 ./Aux__P(ikl,isl)515 516 517 518 C+--Backward Sweep519 C+ ^^^^^^^^^^^^^^520 521 522 eta_SV(ikl,isl) = Aux__Q(ikl,isl) *eta_SV(ikl,isl+1)523 .+eta_SV(ikl,isl)524 525 526 527 528 C+--Horton RunOFF Intensity529 C+ =======================530 531 532 533 534 SatRat = (eta_SV(ikl,isl)-etadSV(ist))! OverSaturation Rate535 . *ro_Wat *dzAvSV(isl)!536 . *LSdzsv(ikl)!537 ./dt__SV !538 SoRnOF(ikl) = SoRnOF(ikl)!539 .+ max(zero,SatRat) !540 RuofSV(ikl,3) = RuofSV(ikl,3) +541 .+ max(zero,SatRat)542 eta_SV(ikl,isl) = max(epsi!543 c#ED. +etamSV(isotSV(ikl))!544 .,eta_SV(ikl,isl)) !545 eta_SV(ikl,isl) = min(eta_SV(ikl,isl)!546 .,etadSV(ist) ) !547 548 549 550 C+--IO, for Verification551 C+ ~~~~~~~~~~~~~~~~~~~~552 c#WR write(6,6010)553 6010 554 555 556 557 558 Khydsv(ikl,isl) =(aKdtSV3(ist,ikp) *eta_SV(ikl,isl)559 .+bKdtSV3(ist,ikp)) *2.0/dt__SV560 c#WR write(6,6011) ikl,isl,eta_SV(ikl,isl)*1.e3,561 c#WR. ikp, aKdtSV3(ist,ikp),bKdtSV3(ist,ikp),562 c#WR. Khydsv(ikl,isl)563 6011 564 565 566 567 568 C+--Additional RunOFF Intensity569 C+ ===========================570 571 572 573 574 c# FreeDr = FreeD0 * min(ist,1)575 576 SoRnOF(ikl) = SoRnOF(ikl)577 . + (aKdtSV3(ist,ik0)*(etaaux(ikl,-nsol)*Explic578 . +eta_SV(ikl,-nsol)*Implic)579 . + bKdtSV3(ist,ik0) )580 .* FreeDr *ro_Wat /dt__SV581 RuofSV(ikl,3) = RuofSV(ikl,3)582 . + (aKdtSV3(ist,ik0)*(etaaux(ikl,-nsol)*Explic583 . +eta_SV(ikl,-nsol)*Implic)584 . + bKdtSV3(ist,ik0) )585 .* FreeDr *ro_Wat /dt__SV586 587 C+--Full Run OFF: Update588 C+ ~~~~~~~~~~~~~~~~~~~~589 590 591 592 593 594 C+--Temperature Correction due to a changed Soil Energy Content595 C+ ===========================================================596 597 C+!!! Mettre en oeuvre le couplage humidit?-?nergie598 599 600 C+--Bumps/Asperites Treatment601 C+ =========================602 603 C+--Average over Bump Depth (z0soil)604 C+ --------------------------------605 606 c#BP z_Bump = 0.607 c#BP DO ikl=1,knonv608 c#BP etBump(ikl) = 0.609 c#BP END DO610 C+611 c#BP DO isl=0,-nsol,-1612 c#BP z0Bump = z_Bump613 c#BP z_Bump = z_Bump + dzAvSV(isl)614 c#BP IF (z_Bump.lt.z0soil) THEN615 c#BP DO ikl=1,knonv616 c#BP etBump(ikl) = etBump(ikl) + dzAvSV(isl) *eta_SV(ikl,isl)617 c#BP END DO618 c#BP END IF619 c#BP IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil) THEN620 c#BP DO ikl=1,knonv621 c#BP etBump(ikl) = etBump(ikl) + (z0soil-z0Bump)*eta_SV(ikl,isl)622 c#BP etBump(ikl) = etBump(ikl) / z0soil623 c#BP END DO624 c#BP END IF625 c#BP END DO626 627 628 C+--Correction629 C+ ----------630 631 c#BP z_Bump = 0.632 c#BP DO isl=0,-nsol,-1633 c#BP z0Bump = z_Bump634 c#BP z_Bump = z_Bump +dzAvSV(isl)635 c#BP IF (z_Bump.lt.z0soil) THEN636 c#BP DO ikl=1,knonv637 c#BP eta_SV(ikl,isl) = etBump(ikl)638 c#BP END DO639 c#BP END IF640 c#BP IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil) THEN641 c#BP dzBump = z_Bump - z0soil642 c#BP DO ikl=1,knonv643 c#BP eta_SV(ikl,isl) =(etBump(ikl) *(dzAvSV(isl)-dzBump)644 c#BP. + eta_SV(ikl,isl)* dzBump)645 c#BP. / dzAvSV(isl)646 c#BP END DO647 c#BP END IF648 c#BP END DO649 650 651 C+--Positive Definite652 C+ =================653 654 c#BP DO isl= 0,-nsol,-1655 c#BP DO ikl= 1,knonv656 c#BP eta_SV(ikl,isl) = max(epsi,eta_SV(ikl,isl))657 c#BP END DO658 c#BP END DO659 660 661 C+--Water Budget (OUT)662 C+ ===================663 664 ! #m0 DO ikl=1,knonv665 ! #m0 Wats_d(ikl) = Wats_d(ikl) !666 ! #m0. + drr_SV(ikl) *zero ! Precipitation is667 C+ \______________ already included668 ! #m0. + HLs_sv(ikl)669 ! #m0. *(1-min(isnoSV(ikl),1)) /Lx_H2O(ikl) ! Evaporation670 ! #m0. - SoRnOF(ikl) ! Soil RunOFF Contrib.671 ! #m0 Wats_1(ikl) = 0. !672 c#mw Evapor(ikl) = HLs_sv(ikl) *dt__SV !673 c#mw. *(1-min(isnoSV(ikl),1)) /Lx_H2O(ikl) !674 ! #m0 END DO675 676 ! #m0 DO isl= -nsol,0677 ! #m0 DO ikl=1,knonv678 ! #m0 Wats_d(ikl) = Wats_d(ikl) !679 ! #m0 END DO680 ! #m0 END DO681 ! #m0 DO ikl=1,knonv682 ! #m0 Wats_d(ikl) = Wats_d(ikl) *dt__SV !683 ! #m0 END DO684 685 ! #m0 isl= -nsol686 ! #m0 DO ikl=1,knonv687 ! #m0 Wats_1(ikl) = Wats_1(ikl)688 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz78SV(isl)689 ! #m0. + eta_SV(ikl,isl+1) *dz_8SV(isl) ) *LSdzsv(ikl)690 ! #m0 END DO691 692 ! #m0 DO isl= -nsol+1,-1693 ! #m0 DO ikl=1,knonv694 ! #m0 Wats_1(ikl) = Wats_1(ikl)695 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz34SV(isl)696 ! #m0. +(eta_SV(ikl,isl-1)697 ! #m0. +eta_SV(ikl,isl+1))*dz_8SV(isl) ) *LSdzsv(ikl)698 ! #m0 END DO699 ! #m0 END DO700 701 ! #m0 isl= 0702 ! #m0 DO ikl=1,knonv703 ! #m0 Wats_1(ikl) = Wats_1(ikl)704 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz78SV(isl)705 ! #m0. + eta_SV(ikl,isl-1) *dz_8SV(isl) ) *LSdzsv(ikl)706 ! #m0 END DO707 708 709 710 end 1 2 3 subroutine SISVAT_qSo 4 ! #m0. (Wats_0,Wats_1,Wats_d) 5 6 ! +------------------------------------------------------------------------+ 7 ! | MAR SISVAT_qSo 6-04-2001 MAR | 8 ! | SubRoutine SISVAT_qSo computes the Soil Water Balance | 9 ! +------------------------------------------------------------------------+ 10 ! | | 11 ! | PARAMETERS: knonv: Total Number of columns = | 12 ! | ^^^^^^^^^^ = Total Number of continental grid boxes | 13 ! | X Number of Mosaic Cell per grid box | 14 ! | | 15 ! | INPUT: isnoSV = total Nb of Ice/Snow Layers | 16 ! | ^^^^^ isotSV = 0,...,11: Soil Type | 17 ! | 0: Water, Solid or Liquid | 18 ! | | 19 ! | INPUT: rhT_SV : SBL Top Air Density [kg/m3] | 20 ! | ^^^^^ drr_SV : Rain Intensity [kg/m2/s] | 21 ! | LSdzsv : Vertical Discretization Factor [-] | 22 ! | = 1. Soil | 23 ! | = 1000. Ocean | 24 ! | dt__SV : Time Step [s] | 25 ! | | 26 ! | Lx_H2O : Latent Heat of Vaporization/Sublimation [J/kg] | 27 ! | HLs_sv : Latent Heat Flux [W/m2] | 28 ! | | 29 ! | INPUT / eta_SV : Water Content [m3/m3] | 30 ! | OUTPUT: Khydsv : Soil Hydraulic Conductivity [m/s] | 31 ! | ^^^^^^ | 32 ! | | 33 ! | OUTPUT: RnofSV : RunOFF Intensity [kg/m2/s] | 34 ! | ^^^^^^ Wats_0 : Soil Water, before Forcing [mm] | 35 ! | Wats_1 : Soil Water, after Forcing [mm] | 36 ! | Wats_d : Soil Water Forcing [mm] | 37 ! | | 38 ! | Internal Variables: | 39 ! | ^^^^^^^^^^^^^^^^^^ | 40 ! | z_Bump : (Partly)Bumpy Layers Height [m] | 41 ! | z0Bump : Bumpy Layers Height [m] | 42 ! | dzBump : Lowest Bumpy Layer: [m] | 43 ! | etBump : Bumps Layer Averaged Humidity [m3/m3] | 44 ! | etaMid : Layer Interface's Humidity [m3/m3] | 45 ! | eta__f : Layer Humidity (Water Front)[m3/m3] | 46 ! | Dhyd_f : Soil Hydraulic Diffusivity (Water Front) [m2/s] | 47 ! | Dhydif : Soil Hydraulic Diffusivity [m2/s] | 48 ! | WgFlow : Water gravitational Flux [kg/m2/s] | 49 ! | Wg_MAX : Water MAXIMUM gravitational Flux [kg/m2/s] | 50 ! | SatRat : Water Saturation Flux [kg/m2/s] | 51 ! | WExces : Water Saturation Excess Flux [kg/m2/s] | 52 ! | Dhydtz : Dhydif * dt / dz [m] | 53 ! | FreeDr : Free Drainage Fraction [-] | 54 ! | Elem_A : A Diagonal Coefficient | 55 ! | Elem_C : C Diagonal Coefficient | 56 ! | Diag_A : A Diagonal | 57 ! | Diag_B : B Diagonal | 58 ! | Diag_C : C Diagonal | 59 ! | Term_D : Independant Term | 60 ! | Aux__P : P Auxiliary Variable | 61 ! | Aux__Q : Q Auxiliary Variable | 62 ! | | 63 ! | TUNING PARAMETER: | 64 ! | ^^^^^^^^^^^^^^^^ | 65 ! | z0soil : Soil Surface averaged Bumps Height [m] | 66 ! | | 67 ! | METHOD: NO Skin Surface Humidity | 68 ! | ^^^^^^ Semi-Implicit Crank Nicholson Scheme | 69 ! | (Partial) free Drainage, Water Bodies excepted (Lakes, Sea) | 70 ! | | 71 72 ! | | 73 ! | # OPTIONS: #GF: Saturation Front | 74 ! | # ^^^^^^^ #GH: Saturation Front allows Horton Runoff | 75 ! | # #GA: Soil Humidity Geometric Average | 76 ! | # #BP: Parameterization of Terrain Bumps | 77 ! | | 78 ! | | 79 ! +------------------------------------------------------------------------+ 80 81 82 83 84 ! +--Global Variables 85 ! + ================ 86 87 use VARphy 88 use VAR_SV 89 use VARdSV 90 use VAR0SV 91 use VARxSV 92 use VARySV 93 94 95 IMPLICIT NONE 96 97 98 ! +--OUTPUT 99 ! + ------ 100 101 ! Water (Mass) Budget 102 ! ~~~~~~~~~~~~~~~~~~~ 103 ! #m0 real Wats_0(knonv) ! Soil Water, before forcing 104 ! #m0 real Wats_1(knonv) ! Soil Water, after forcing 105 ! #m0 real Wats_d(knonv) ! Soil Water forcing 106 107 108 ! +--Internal Variables 109 ! + ================== 110 111 integer :: isl ,jsl ,ist ,ikl ! 112 integer :: ikm ,ikp ,ik0 ,ik1 ! 113 integer :: ist__s,ist__w ! Soil/Water Body Identifier 114 ! #BP real z0soil ! Soil Surface Bumps Height [m] 115 ! #BP real z_Bump !(Partly)Bumpy Layers Height [m] 116 ! #BP real z0Bump ! Bumpy Layers Height [m] 117 ! #BP real dzBump ! Lowest Bumpy Layer: 118 119 ! #BP real etBump(knonv) ! Bumps Layer Averaged Humidity 120 real :: etaMid ! Layer Interface's Humidity 121 real :: Dhydif ! Hydraulic Diffusivity [m2/s] 122 real :: eta__f ! Water Front Soil Water Content 123 real :: Khyd_f ! Water Front Hydraulic Conduct. 124 real :: Khydav ! Hydraulic Conductivity [m/s] 125 real :: WgFlow ! Water gravitat. Flux [kg/m2/s] 126 real :: Wg_MAX ! Water MAX.grav. Flux [kg/m2/s] 127 real :: SatRat ! Saturation Flux [kg/m2/s] 128 real :: WExces ! Saturat. Excess Flux [kg/m2/s] 129 real :: SoRnOF(knonv) ! Soil Run OFF 130 real :: Dhydtz(knonv,-nsol:0) ! Dhydif * dt / dz [m] 131 real :: Elem_A,Elem_B,Elem_C ! Diagonal Coefficients 132 real :: Diag_A(knonv,-nsol:0) ! A Diagonal 133 real :: Diag_B(knonv,-nsol:0) ! B Diagonal 134 real :: Diag_C(knonv,-nsol:0) ! C Diagonal 135 real :: Term_D(knonv,-nsol:0) ! Independant Term 136 real :: Aux__P(knonv,-nsol:0) ! P Auxiliary Variable 137 real :: Aux__Q(knonv,-nsol:0) ! Q Auxiliary Variable 138 real :: etaaux(knonv,-nsol:-nsol+1) ! Soil Water Content [m3/m3] 139 real :: FreeDr ! Free Drainage Fraction (actual) 140 real :: FreeD0 ! Free Drainage Fraction (1=Full) 141 real :: aKdtSV3( 0:nsot, 0:nkhy) ! Khyd=a*eta+b: a * dt 142 real :: bKdtSV3( 0:nsot, 0:nkhy) ! Khyd=a*eta+b: b * dt 143 144 ! Water (Mass) Budget 145 ! ~~~~~~~~~~~~~~~~~~~ 146 ! #mw logical mwopen ! IO Switch 147 ! #mw common/Sm_qSo_L/mwopen ! 148 ! #mw real hourwr,timewr ! 149 ! #mw common/Sm_qSo_R/timewr ! 150 ! #mw real Evapor(knonv) ! 151 152 153 ! +--Internal DATA 154 ! + ============= 155 156 ! #BP data z0soil/0.020/ ! Soil Surface Bumps Height [m] 157 data FreeD0/1.000/ ! Free Drainage Fraction (1=Full) 158 159 aKdtSV3=aKdtSV2*dt__SV 160 bKdtSV3=bKdtSV2*dt__SV 161 162 ! Water Budget (IN) 163 ! ================== 164 165 ! #m0 DO ikl=1,knonv 166 ! #m0 Wats_0(ikl) = 0. ! OLD RunOFF Contrib. 167 ! #m0 Wats_d(ikl) = drr_SV(ikl) ! Water Surface Forc. 168 ! #m0 END DO 169 170 ! #m0 isl= -nsol 171 ! #m0 DO ikl=1,knonv 172 ! #m0 Wats_0(ikl) = Wats_0(ikl) 173 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz78SV(isl) 174 ! #m0. + eta_SV(ikl,isl+1) *dz_8SV(isl) ) * LSdzsv(ikl) 175 ! #m0 END DO 176 177 ! #m0 DO isl= -nsol+1,-1 178 ! #m0 DO ikl=1,knonv 179 ! #m0 Wats_0(ikl) = Wats_0(ikl) 180 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz34SV(isl) 181 ! #m0. +(eta_SV(ikl,isl-1) 182 ! #m0. +eta_SV(ikl,isl+1))*dz_8SV(isl) ) * LSdzsv(ikl) 183 ! #m0 END DO 184 ! #m0 END DO 185 186 ! #m0 isl= 0 187 ! #m0 DO ikl=1,knonv 188 ! #m0 Wats_0(ikl) = Wats_0(ikl) 189 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz78SV(isl) 190 ! #m0. + eta_SV(ikl,isl-1) *dz_8SV(isl) ) * LSdzsv(ikl) 191 ! #m0 END DO 192 193 194 ! +--Gravitational Flow 195 ! + ================== 196 197 ! +... METHOD: Surface Water Flux saturates successively the soil layers 198 ! + ^^^^^^ from up to below, but is limited by infiltration capacity. 199 ! + Hydraulic Conductivity again contributes after this step, 200 ! + not redundantly because of a constant (saturated) profile. 201 202 ! +--Flux Limitor 203 ! + ^^^^^^^^^^^^^ 204 isl=0 205 DO ikl=1,knonv 206 ist = isotSV(ikl) ! Soil Type 207 ist__s = min(ist, 1) ! 1 => Soil 208 ist__w = 1 - ist__s ! 1 => Water Body 209 Dhydif = s1__SV(ist) & 210 *max(epsi,eta_SV(ikl,isl)) & ! Hydraulic Diffusivity 211 **(bCHdSV(ist)+2.) ! DR97, Eqn.(3.36) 212 Dhydif = ist__s * Dhydif & ! 213 + ist__w * vK_dSV ! Water Bodies 214 ! + 215 Khydav = ist__s * Ks_dSV(ist) & ! DR97 Assumption 216 + ist__w * vK_dSV ! Water Bodies 217 ! + 218 Wg_MAX = ro_Wat *Dhydif & ! MAXimum Infiltration 219 *(etadSV(ist)-eta_SV(ikl,isl)) & ! Rate 220 /(dzAvSV(isl)*LSdzsv(ikl) ) & ! 221 + ro_Wat *Khydav ! 222 223 ! +--Surface Horton RunOFF 224 ! + ^^^^^^^^^^^^^^^^^^^^^ 225 SoRnOF(ikl) = & 226 max(zero,drr_SV(ikl)-Wg_MAX) 227 RuofSV(ikl,1) = RuofSV(ikl,1) + SoRnOF(ikl) 228 drr_SV(ikl) = drr_SV(ikl)-SoRnOF(ikl) 229 RuofSV(ikl,2) = RuofSV(ikl,2) +max(0.,drr_SV(ikl)) 230 END DO 231 232 ! #GF DO isl=0,-nsol,-1 233 ! #GF DO ikl=1,knonv 234 ! #GF ist = isotSV(ikl) ! Soil Type 235 ! #GF ist__s = min(ist, 1) ! 1 => Soil 236 ! #GF ist__w = 1 - ist__s ! 1 => Water Body 237 238 ! +--Water Diffusion 239 ! + ^^^^^^^^^^^^^^^ 240 ! #GF Dhydif = s1__SV(ist) 241 ! #GF. *max(epsi,eta_SV(ikl,isl)) ! Hydraulic Diffusivity 242 ! #GF. **(bCHdSV(ist)+2.) ! DR97, Eqn.(3.36) 243 ! #GF Dhydif = ist__s * Dhydif ! 244 ! #GF. + ist__w * vK_dSV ! Water Bodies 245 246 ! +--Water Conduction (without Horton Runoff) 247 ! + ^^^^^^^^^^^^^^^^ 248 ! #GF Khyd_f = Ks_dSV(ist) 249 ! +... Uses saturated K ==> Horton Runoff ~0 ! 250 251 ! +--Water Conduction (with Horton Runoff) 252 ! + ^^^^^^^^^^^^^^^^ 253 ! #GH ik0 = nkhy *eta_SV(ikl,isl) 254 ! #GH. /etadSV(ist) 255 ! #GH eta__f = 1. 256 ! #GH. -aKdtSV3(ist,ik0)/(2. *dzAvSV(isl) 257 ! #GH. *LSdzsv(ikl)) 258 ! #GH eta__f = max(eps_21,eta__f) 259 ! #GH eta__f = min(etadSV(ist), 260 ! #GH. eta_SV(ikl,isl) + 261 ! #GH. (aKdtSV3(ist,ik0) *eta_SV(ikl,isl) 262 ! #GH. +bKdtSV3(ist,ik0)) /(dzAvSV(isl) 263 ! #GH. *LSdzsv(ikl)) 264 ! #GH. / eta__f ) 265 ! #GH eta__f = .5*(eta_SV(ikl,isl) 266 ! #GH. +eta__f) 267 268 ! #gh eta__f = eta_SV(ikl,isl) 269 270 ! #GH ik0 = nkhy *eta__f 271 ! #GH. /etadSV(ist) 272 ! #GH Khyd_f = 273 ! #GH. (aKdtSV3(ist,ik0) *eta__f 274 ! #GH. +bKdtSV3(ist,ik0)) /dt__SV 275 276 ! #GF Khydav = ist__s * Khyd_f ! DR97 Assumption 277 ! #GF. + ist__w * vK_dSV ! Water Bodies 278 279 ! +--Gravitational Flow 280 ! + ^^^^^^^^^^^^^^^^^^ 281 ! #GF Wg_MAX = ! MAXimum Infiltration 282 ! #GF. ro_Wat *Dhydif ! Rate 283 ! #GF. *(etadSV(ist)-eta_SV(ikl,isl)) ! 284 ! #GF. /(dzAvSV(isl)*LSdzsv(ikl) ) ! 285 ! #GF. + ro_Wat *Khydav ! 286 ! #GF END DO 287 ! #GF END DO 288 ! #GF DO ikl=1,knonv 289 ! #GF SoRnOF(ikl) = SoRnOF(ikl) ! RunOFF Intensity 290 ! #GF. + drr_SV(ikl) ! [kg/m2/s] 291 ! +!!! Inclure la possibilite de creer une mare sur un bedrock impermeable 292 ! #GF drr_SV(ikl) = 0. 293 ! #GF END DO 294 295 296 ! +--Temperature Correction due to a changed Soil Energy Content 297 ! + =========================================================== 298 299 ! +!!! Mettre en oeuvre le couplage humidit?-?nergie 300 301 302 ! +--Full Resolution of the Richard's Equation 303 ! + ========================================= 304 305 ! +... METHOD: Water content evolution results from water fluxes 306 ! + ^^^^^^ at the layer boundaries 307 ! + Conductivity is approximated by a piecewise linear profile. 308 ! + Semi-Implicit Crank-Nicholson scheme is used. 309 ! + (Bruen, 1997, Sensitivity of hydrological processes 310 ! + at the land-atmosphere interface. 311 ! + Proc. Royal Irish Academy, IGBP symposium 312 ! + on global change and the Irish Environment. 313 ! + Publ.: Maynooth) 314 315 ! + - - - - - - - - isl+1/2 - - ^ 316 ! + | 317 ! + eta_SV(isl) --------------- isl ----- +--dz_dSV(isl) ^ 318 ! + | | 319 ! + Dhydtz(isl) etaMid - - - - - - - - isl-1/2 - - v dzmiSV(isl)--+ 320 ! + | 321 ! + eta_SV(isl-1) --------------- isl-1 ----- v 322 323 ! +--Transfert Coefficients 324 ! + ---------------------------- 325 326 DO isl=-nsol+1,0 327 DO ikl=1,knonv 328 ist = isotSV(ikl) ! Soil Type 329 ist__s = min(ist, 1) ! 1 => Soil 330 ist__w = 1 - ist__s ! 1 => Water Body 331 etaMid = (dz_dSV(isl) *eta_SV(ikl,isl-1) & ! eta at layers 332 +dz_dSV(isl-1)*eta_SV(ikl,isl) ) & ! interface 333 /(2.0* dzmiSV(isl)) ! LSdzsv implicit ! 334 ! #GA etaMid = sqrt(dz_dSV(isl) *eta_SV(ikl,isl-1) ! Idem, geometric 335 ! #GA. *dz_dSV(isl-1)*eta_SV(ikl,isl) ) ! average 336 ! #GA. /(2.0* dzmiSV(isl)) ! (Vauclin&al.1979) 337 Dhydif = s1__SV(ist) & ! Hydraul.Diffusi. 338 *(etaMid **( bCHdSV(ist)+2.)) ! DR97, Eqn.(3.36) 339 Dhydtz(ikl,isl) = Dhydif*dt__SV & ! 340 /(dzmiSV(isl) & ! 341 *LSdzsv(ikl)) ! 342 Dhydtz(ikl,isl) = Dhydtz(ikl,isl) * ist__s & ! Soil 343 +0.5*dzmiSV(isl)*LSdzsv(ikl) * ist__w ! Water bodies 344 345 END DO 346 END DO 347 isl=-nsol 348 DO ikl=1,knonv 349 Dhydtz(ikl,isl) = 0.0 ! 350 END DO 351 352 353 ! +--Tridiagonal Elimination: Set Up 354 ! + ------------------------------- 355 356 ! +--Soil/Snow Interior 357 ! + ^^^^^^^^^^^^^^^^^^ 358 359 DO isl=0,-nsol,-1 360 DO ikl=1,knonv 361 ist = isotSV(ikl) 362 eta_SV(ikl,isl) = max(epsi, eta_SV(ikl,isl)) 363 END DO 364 END DO 365 366 DO isl=-nsol,-nsol+1 367 DO ikl=1,knonv 368 etaaux(ikl,isl) = eta_SV(ikl,isl) 369 END DO 370 END DO 371 372 DO isl=-nsol+1,-1 373 DO ikl=1,knonv 374 ist = isotSV(ikl) 375 ikm = nkhy * eta_SV(ikl,isl-1) / etadSV(ist) 376 ik0 = nkhy * eta_SV(ikl,isl) / etadSV(ist) 377 ikp = nkhy * eta_SV(ikl,isl+1) / etadSV(ist) 378 379 if(ikm<0.or.ik0<0.or.ikp<0)then 380 print *,"CRASH1 in sisvat_qso.f on pixel (i,j,n)", & 381 ii__SV(ikl),jj__SV(ikl),nn__SV(ikl) 382 print *,"decrease your time step or increase ntphys "// & 383 "and ntdiff in time_steps.f" 384 stop 385 endif 386 387 388 Elem_A = Dhydtz(ikl,isl) & 389 - aKdtSV3(ist,ikm)* dziiSV(isl) *LSdzsv(ikl) 390 Elem_B = - (Dhydtz(ikl,isl) & 391 +Dhydtz(ikl,isl+1) & 392 -aKdtSV3(ist,ik0)*(dziiSV(isl+1) & 393 -dzi_SV(isl) )*LSdzsv(ikl)) 394 Elem_C = Dhydtz(ikl,isl+1) & 395 + aKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl) 396 Diag_A(ikl,isl) = dz_8SV(isl) *LSdzsv(ikl) & 397 -Implic * Elem_A 398 Diag_B(ikl,isl) = dz34SV(isl) *LSdzsv(ikl) & 399 -Implic * Elem_B 400 Diag_C(ikl,isl) = dz_8SV(isl) *LSdzsv(ikl) & 401 -Implic * Elem_C 402 403 Term_D(ikl,isl) = (dz_8SV(isl) *LSdzsv(ikl) & 404 +Explic *Elem_A )*eta_SV(ikl,isl-1) & 405 + (dz34SV(isl) *LSdzsv(ikl) & 406 +Explic *Elem_B )*eta_SV(ikl,isl) & 407 + (dz_8SV(isl) *LSdzsv(ikl) & 408 +Explic *Elem_C )*eta_SV(ikl,isl+1) & 409 + (bKdtSV3(ist,ikp)* dzi_SV(isl+1) & 410 +bKdtSV3(ist,ik0)*(dziiSV(isl+1) & 411 -dzi_SV(isl) ) & 412 -bKdtSV3(ist,ikm)* dziiSV(isl) ) & 413 * LSdzsv(ikl) 414 END DO 415 END DO 416 417 isl=-nsol 418 DO ikl=1,knonv 419 ist = isotSV(ikl) 420 ! # FreeDr = FreeD0 * min(ist,1) 421 FreeDr = iWaFSV(ikl) * min(ist,1) 422 ik0 = nkhy * eta_SV(ikl,isl ) / etadSV(ist) 423 ikp = nkhy * eta_SV(ikl,isl+1) / etadSV(ist) 424 425 if(ik0<0.or.ikp<0)then 426 print *,"CRASH2 in sisvat_qso.f on pixel (i,j,n)", & 427 ii__SV(ikl),jj__SV(ikl),nn__SV(ikl) 428 print *,"decrease your time step or increase ntphys "// & 429 "and ntdiff in time_steps.f" 430 stop 431 endif 432 433 Elem_A = 0. 434 Elem_B = - (Dhydtz(ikl,isl+1) & 435 -aKdtSV3(ist,ik0)*(dziiSV(isl+1)*LSdzsv(ikl) & 436 -FreeDr )) 437 Elem_C = Dhydtz(ikl,isl+1) & 438 + aKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl) 439 Diag_A(ikl,isl) = 0. 440 Diag_B(ikl,isl) = dz78SV(isl) *LSdzsv(ikl) & 441 -Implic *Elem_B 442 Diag_C(ikl,isl) = dz_8SV(isl) *LSdzsv(ikl) & 443 -Implic *Elem_C 444 445 Term_D(ikl,isl) = (dz78SV(isl) *LSdzsv(ikl) & 446 +Explic *Elem_B )*eta_SV(ikl,isl) & 447 + (dz_8SV(isl) *LSdzsv(ikl) & 448 +Explic *Elem_C )*eta_SV(ikl,isl+1) & 449 + (bKdtSV3(ist,ikp)* dzi_SV(isl+1)*LSdzsv(ikl) & 450 +bKdtSV3(ist,ik0)*(dziiSV(isl+1)*LSdzsv(ikl) & 451 -FreeDr )) 452 END DO 453 454 isl=0 455 DO ikl=1,knonv 456 ist = isotSV(ikl) 457 ikm = nkhy * eta_SV(ikl,isl-1) / etadSV(ist) 458 ik0 = nkhy * eta_SV(ikl,isl) / etadSV(ist) 459 Elem_A = Dhydtz(ikl,isl) & 460 - aKdtSV3(ist,ikm)* dziiSV(isl)*LSdzsv(ikl) 461 Elem_B = - (Dhydtz(ikl,isl) & 462 +aKdtSV3(ist,ik0)* dzi_SV(isl)*LSdzsv(ikl)) 463 Elem_C = 0. 464 Diag_A(ikl,isl) = dz_8SV(isl) *LSdzsv(ikl) & 465 - Implic *Elem_A 466 Diag_B(ikl,isl) = dz78SV(isl) *LSdzsv(ikl) & 467 - Implic *Elem_B 468 Diag_C(ikl,isl) = 0. 469 ! + 470 Term_D(ikl,isl) = (dz_8SV(isl) *LSdzsv(ikl) & 471 +Explic *Elem_A )*eta_SV(ikl,isl-1) & 472 + (dz78SV(isl) *LSdzsv(ikl) & 473 +Explic *Elem_B )*eta_SV(ikl,isl) & 474 - (bKdtSV3(ist,ik0)* dzi_SV(isl) & 475 +bKdtSV3(ist,ikm)* dziiSV(isl))*LSdzsv(ikl) & 476 + dt__SV *(HLs_sv(ikl) * (1-min(1,isnoSV(ikl))) & 477 / (ro_Wat *dz_dSV(0) * Lx_H2O(ikl)) & 478 !XF bug 17/05/2017 479 +drr_SV(ikl))/ro_Wat 480 END DO 481 482 DO ikl=1,knonv 483 drr_SV(ikl)=0. ! drr is included in the 1st soil layer 484 ENDDO 485 486 ! + 487 ! + 488 ! +--Tridiagonal Elimination 489 ! + ======================= 490 ! + 491 ! +--Forward Sweep 492 ! + ^^^^^^^^^^^^^^ 493 DO ikl= 1,knonv 494 Aux__P(ikl,-nsol) = Diag_B(ikl,-nsol) 495 Aux__Q(ikl,-nsol) =-Diag_C(ikl,-nsol)/Aux__P(ikl,-nsol) 496 END DO 497 ! + 498 DO isl=-nsol+1,0 499 DO ikl= 1,knonv 500 Aux__P(ikl,isl) = Diag_A(ikl,isl) *Aux__Q(ikl,isl-1) & 501 +Diag_B(ikl,isl) 502 Aux__Q(ikl,isl) =-Diag_C(ikl,isl) /Aux__P(ikl,isl) 503 END DO 504 END DO 505 ! + 506 DO ikl= 1,knonv 507 eta_SV(ikl,-nsol) = Term_D(ikl,-nsol)/Aux__P(ikl,-nsol) 508 END DO 509 ! + 510 DO isl=-nsol+1,0 511 DO ikl= 1,knonv 512 eta_SV(ikl,isl) =(Term_D(ikl,isl) & 513 -Diag_A(ikl,isl) *eta_SV(ikl,isl-1)) & 514 /Aux__P(ikl,isl) 515 END DO 516 END DO 517 518 ! +--Backward Sweep 519 ! + ^^^^^^^^^^^^^^ 520 DO isl=-1,-nsol,-1 521 DO ikl= 1,knonv 522 eta_SV(ikl,isl) = Aux__Q(ikl,isl) *eta_SV(ikl,isl+1) & 523 +eta_SV(ikl,isl) 524 END DO 525 END DO 526 527 528 ! +--Horton RunOFF Intensity 529 ! + ======================= 530 531 DO isl=0,-nsol,-1 532 DO ikl=1,knonv 533 ist = isotSV(ikl) ! Soil Type 534 SatRat = (eta_SV(ikl,isl)-etadSV(ist)) & ! OverSaturation Rate 535 *ro_Wat *dzAvSV(isl) & ! 536 *LSdzsv(ikl) & ! 537 /dt__SV ! 538 SoRnOF(ikl) = SoRnOF(ikl) & ! 539 + max(zero,SatRat) ! 540 RuofSV(ikl,3) = RuofSV(ikl,3) + & 541 + max(zero,SatRat) 542 eta_SV(ikl,isl) = max(epsi & ! 543 ! #ED. +etamSV(isotSV(ikl))! 544 ,eta_SV(ikl,isl)) ! 545 eta_SV(ikl,isl) = min(eta_SV(ikl,isl) & ! 546 ,etadSV(ist) ) ! 547 END DO 548 END DO 549 550 ! +--IO, for Verification 551 ! + ~~~~~~~~~~~~~~~~~~~~ 552 ! #WR write(6,6010) 553 6010 format(/,1x) 554 DO isl= 0,-nsol,-1 555 DO ikl= 1,knonv 556 ist = isotSV(ikl) 557 ikp = nkhy * eta_SV(ikl,isl) /etadSV(ist) 558 Khydsv(ikl,isl) =(aKdtSV3(ist,ikp) *eta_SV(ikl,isl) & 559 +bKdtSV3(ist,ikp)) *2.0/dt__SV 560 ! #WR write(6,6011) ikl,isl,eta_SV(ikl,isl)*1.e3, 561 ! #WR. ikp, aKdtSV3(ist,ikp),bKdtSV3(ist,ikp), 562 ! #WR. Khydsv(ikl,isl) 563 6011 format(2i3,f8.1,i3,3e12.3) 564 END DO 565 END DO 566 567 568 ! +--Additional RunOFF Intensity 569 ! + =========================== 570 571 DO ikl=1,knonv 572 ist = isotSV(ikl) 573 ik0 = nkhy * etaaux(ikl,-nsol ) /etadSV(ist) 574 ! # FreeDr = FreeD0 * min(ist,1) 575 FreeDr = iWaFSV(ikl) * min(ist,1) 576 SoRnOF(ikl) = SoRnOF(ikl) & 577 + (aKdtSV3(ist,ik0)*(etaaux(ikl,-nsol)*Explic & 578 +eta_SV(ikl,-nsol)*Implic) & 579 + bKdtSV3(ist,ik0) ) & 580 * FreeDr *ro_Wat /dt__SV 581 RuofSV(ikl,3) = RuofSV(ikl,3) & 582 + (aKdtSV3(ist,ik0)*(etaaux(ikl,-nsol)*Explic & 583 +eta_SV(ikl,-nsol)*Implic) & 584 + bKdtSV3(ist,ik0) ) & 585 * FreeDr *ro_Wat /dt__SV 586 587 ! +--Full Run OFF: Update 588 ! + ~~~~~~~~~~~~~~~~~~~~ 589 RnofSV(ikl) = RnofSV(ikl) + SoRnOF(ikl) 590 RuofSV(ikl,4) = RuofSV(ikl,4) + SoRnOF(ikl) 591 END DO 592 593 594 ! +--Temperature Correction due to a changed Soil Energy Content 595 ! + =========================================================== 596 597 ! +!!! Mettre en oeuvre le couplage humidit?-?nergie 598 599 600 ! +--Bumps/Asperites Treatment 601 ! + ========================= 602 603 ! +--Average over Bump Depth (z0soil) 604 ! + -------------------------------- 605 606 ! #BP z_Bump = 0. 607 ! #BP DO ikl=1,knonv 608 ! #BP etBump(ikl) = 0. 609 ! #BP END DO 610 ! + 611 ! #BP DO isl=0,-nsol,-1 612 ! #BP z0Bump = z_Bump 613 ! #BP z_Bump = z_Bump + dzAvSV(isl) 614 ! #BP IF (z_Bump.lt.z0soil) THEN 615 ! #BP DO ikl=1,knonv 616 ! #BP etBump(ikl) = etBump(ikl) + dzAvSV(isl) *eta_SV(ikl,isl) 617 ! #BP END DO 618 ! #BP END IF 619 ! #BP IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil) THEN 620 ! #BP DO ikl=1,knonv 621 ! #BP etBump(ikl) = etBump(ikl) + (z0soil-z0Bump)*eta_SV(ikl,isl) 622 ! #BP etBump(ikl) = etBump(ikl) / z0soil 623 ! #BP END DO 624 ! #BP END IF 625 ! #BP END DO 626 627 628 ! +--Correction 629 ! + ---------- 630 631 ! #BP z_Bump = 0. 632 ! #BP DO isl=0,-nsol,-1 633 ! #BP z0Bump = z_Bump 634 ! #BP z_Bump = z_Bump +dzAvSV(isl) 635 ! #BP IF (z_Bump.lt.z0soil) THEN 636 ! #BP DO ikl=1,knonv 637 ! #BP eta_SV(ikl,isl) = etBump(ikl) 638 ! #BP END DO 639 ! #BP END IF 640 ! #BP IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil) THEN 641 ! #BP dzBump = z_Bump - z0soil 642 ! #BP DO ikl=1,knonv 643 ! #BP eta_SV(ikl,isl) =(etBump(ikl) *(dzAvSV(isl)-dzBump) 644 ! #BP. + eta_SV(ikl,isl)* dzBump) 645 ! #BP. / dzAvSV(isl) 646 ! #BP END DO 647 ! #BP END IF 648 ! #BP END DO 649 650 651 ! +--Positive Definite 652 ! + ================= 653 654 ! #BP DO isl= 0,-nsol,-1 655 ! #BP DO ikl= 1,knonv 656 ! #BP eta_SV(ikl,isl) = max(epsi,eta_SV(ikl,isl)) 657 ! #BP END DO 658 ! #BP END DO 659 660 661 ! +--Water Budget (OUT) 662 ! + =================== 663 664 ! #m0 DO ikl=1,knonv 665 ! #m0 Wats_d(ikl) = Wats_d(ikl) ! 666 ! #m0. + drr_SV(ikl) *zero ! Precipitation is 667 ! + \______________ already included 668 ! #m0. + HLs_sv(ikl) 669 ! #m0. *(1-min(isnoSV(ikl),1)) /Lx_H2O(ikl) ! Evaporation 670 ! #m0. - SoRnOF(ikl) ! Soil RunOFF Contrib. 671 ! #m0 Wats_1(ikl) = 0. ! 672 ! #mw Evapor(ikl) = HLs_sv(ikl) *dt__SV ! 673 ! #mw. *(1-min(isnoSV(ikl),1)) /Lx_H2O(ikl) ! 674 ! #m0 END DO 675 676 ! #m0 DO isl= -nsol,0 677 ! #m0 DO ikl=1,knonv 678 ! #m0 Wats_d(ikl) = Wats_d(ikl) ! 679 ! #m0 END DO 680 ! #m0 END DO 681 ! #m0 DO ikl=1,knonv 682 ! #m0 Wats_d(ikl) = Wats_d(ikl) *dt__SV ! 683 ! #m0 END DO 684 685 ! #m0 isl= -nsol 686 ! #m0 DO ikl=1,knonv 687 ! #m0 Wats_1(ikl) = Wats_1(ikl) 688 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz78SV(isl) 689 ! #m0. + eta_SV(ikl,isl+1) *dz_8SV(isl) ) *LSdzsv(ikl) 690 ! #m0 END DO 691 692 ! #m0 DO isl= -nsol+1,-1 693 ! #m0 DO ikl=1,knonv 694 ! #m0 Wats_1(ikl) = Wats_1(ikl) 695 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz34SV(isl) 696 ! #m0. +(eta_SV(ikl,isl-1) 697 ! #m0. +eta_SV(ikl,isl+1))*dz_8SV(isl) ) *LSdzsv(ikl) 698 ! #m0 END DO 699 ! #m0 END DO 700 701 ! #m0 isl= 0 702 ! #m0 DO ikl=1,knonv 703 ! #m0 Wats_1(ikl) = Wats_1(ikl) 704 ! #m0. + ro_Wat *( eta_SV(ikl,isl) *dz78SV(isl) 705 ! #m0. + eta_SV(ikl,isl-1) *dz_8SV(isl) ) *LSdzsv(ikl) 706 ! #m0 END DO 707 708 709 return 710 end subroutine sisvat_qso -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_sno_albedo.f90
r5245 r5246 1 subroutine SnOptP(jjtime) 2 3 C +------------------------------------------------------------------------+ 4 C | MAR/SISVAT SnOptP 12-08-2019 MAR | 5 C | SubRoutine SnOptP computes the Snow Pack optical Properties | 6 C +------------------------------------------------------------------------+ 7 C | | 8 C | PARAMETERS: knonv: Total Number of columns = | 9 C | ^^^^^^^^^^ = Total Number of continental Grid Boxes | 10 C | X Number of Mosaic Cell per Grid Box | 11 C | | 12 C | INPUT: isnoSV = total Nb of Ice/Snow Layers | 13 C | ^^^^^ ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer | 14 C | | 15 C | | 16 C | INPUT: G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer | 17 C | ^^^^^ G2snSV : Sphericity (>0) or Size of Snow Layer | 18 C | agsnSV : Snow Age [day] | 19 C | ro__SV : Snow/Soil Volumic Mass [kg/m3] | 20 C | eta_SV : Water Content [m3/m3] | 21 C | rusnSV : Surficial Water Thickness [kg/m2] .OR. [mm] | 22 C | SWS_SV : Surficial Water Status | 23 C | dzsnSV : Snow Layer Thickness [m] | 24 C | | 25 C | albssv : Soil Albedo [-] | 26 C | zzsnsv : Snow Pack Thickness [m] | 27 C | | 28 C | OUTPUT: albisv : Snow/Ice/Water/Soil Integrated Albedo [-] | 29 C | ^^^^^^ sEX_sv : Verticaly Integrated Extinction Coefficient | 30 C | DOPsnSV : Snow Optical diameter [m] | 31 C | | 32 C | Internal Variables: | 33 C | ^^^^^^^^^^^^^^^^^^ | 34 C | SnOpSV : Snow Grain optical Size [m] | 35 C | EX1_sv : Integrated Snow Extinction (0.3--0.8micr.m) | 36 C | EX2_sv : Integrated Snow Extinction (0.8--1.5micr.m) | 37 C | EX3_sv : Integrated Snow Extinction (1.5--2.8micr.m) | 38 C | | 39 C | METHODE: Calcul de la taille optique des grains ? partir de | 40 C | ^^^^^^^ -leur type decrit par les deux variables descriptives | 41 C | continues sur la plage -99/+99 passees en appel. | 42 C | -la taille optique (1/10mm) des etoiles, | 43 C | des grains fins et | 44 C | des jeunes faces planes | 45 C | | 46 C | METHOD: Computation of the optical diameter of the grains | 47 C | ^^^^^^ described with the CROCUS formalism G1snSV / G2snSV | 48 C | | 49 C | REFERENCE: Brun et al. 1989, J. Glaciol 35 pp. 333--342 | 50 C | ^^^^^^^^^ Brun et al. 1992, J. Glaciol 38 pp. 13-- 22 | 51 C | Eric Martin Sept.1996 | 52 C | | 53 C | | 54 C +------------------------------------------------------------------------+ 55 56 57 58 59 C +--Global Variables 60 C + ================ 61 62 63 use VARphy 64 use VAR_SV 65 use VARdSV 66 use VARxSV 67 use VARySV 68 use VARtSV 69 USE surface_data, only: iflag_albcalc,correc_alb 70 71 IMPLICIT NONE 72 73 74 C + -- INPUT 75 integer jjtime 76 77 C +--Internal Variables 78 C + ================== 79 80 real coalb1(knonv) ! weighted Coalbedo, Vis. 81 real coalb2(knonv) ! weighted Coalbedo, nIR 1 82 real coalb3(knonv) ! weighted Coalbedo, nIR 2 83 real coalbm ! weighted Coalbedo, mean 84 real sExt_1(knonv) ! Extinction Coeff., Vis. 85 real sExt_2(knonv) ! Extinction Coeff., nIR 1 86 real sExt_3(knonv) ! Extinction Coeff., nIR 2 87 real SnOpSV(knonv, nsno) ! Snow Grain optical Size 88 c #AG real agesno 89 90 integer isn ,ikl ,isn1, i 91 real sbeta1,sbeta2,sbeta3,sbeta4,sbeta5 92 real AgeMax,AlbMin,HSnoSV,HIceSV,doptmx,SignG1,Sph_OK 93 real dalbed,dalbeS,dalbeW 94 real bsegal,czemax,csegal,csza 95 real RoFrez,DiffRo,SignRo,SnowOK,OpSqrt 96 real albSn1,albIc1,a_SnI1,a_SII1 97 real albSn2,albIc2,a_SnI2,a_SII2 98 real albSn3,albIc3,a_SnI3,a_SII3 99 real albSno,albIce,albSnI,albSII,albWIc,albmax 100 real doptic,Snow_H,SIce_H,SnownH,SIcenH 101 real exarg1,exarg2,exarg3,sign_0,sExt_0 102 real albedo_old,albCor 103 real ro_ave,dz_ave,minalb 104 real l1min,l1max,l2min,l2max,l3min,l3max 105 real l6min(6), l6max(6), albSn6(6), a_SII6(6) 106 real lmintmp,lmaxtmp,albtmp 107 108 C +--Local DATA 109 C + ============ 110 111 C +--For the computation of the solar irradiance extinction in snow 112 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 113 data sbeta1/0.0192/,sbeta2/0.4000/,sbeta3/0.1098/ 114 data sbeta4/1.0000/ 115 data sbeta5/2.00e1/ 116 117 C +--Snow Age Maximum (Taiga, e.g. Col de Porte) 118 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 119 data AgeMax /60.0/ 120 C +... AgeMax: Snow Age Maximum [day] 121 122 data AlbMin /0.94/ 123 C +... AlbMin: Albedo Minimum / visible (0.3--0.8 micrometers) 124 125 data HSnoSV /0.01/ 126 C +... HSnoSV: Snow Thickness through witch 127 C + Albedo is interpolated to Ice Albedo 128 data HIceSV /0.10/ 129 C +... HIceSV: Snow/Ice Thickness through witch 130 C + Albedo is interpolated to Soil Albedo 131 data doptmx /2.3e-3/ 132 C +... doptmx: Maximum optical Diameter (pi * R**2) [m] 133 C + 134 data czeMAX /0.173648178/ ! 80.deg (Segal et al., 1991 JAS) 135 136 data bsegal /4.00 / ! 137 data albmax /0.99 / ! Albedo max 138 139 C +-- wavelength limits [m] for each broad band 140 141 data l1min/400.0e-9/,l1max/800.0e-9/ 142 data l2min/800.0e-9/,l2max/1500.0e-9/ 143 data l3min/1500.0e-9/,l3max/2800.0e-9/ 144 145 data l6min/185.0e-9,250.0e-9,400.0e-9, 146 . 690.0e-9,1190.0e-9,2380.0e-9/ 147 data l6max/250.0e-9,400.0e-9, 148 . 690.0e-9,1190.0e-9,2380.0e-9,4000.0e-9/ 149 150 151 C +--Snow Grain optical Size 152 C + ======================= 153 154 DO ikl=1,knonv 155 DO isn=1,max(1,isnoSV(ikl)) 156 157 G2snSV(ikl,isn) = max(epsi,G2snSV(ikl,isn)) 158 C +... Avoid non physical Values 159 160 SignG1 = sign(unun,G1snSV(ikl,isn)) 161 Sph_OK = max(zero,SignG1) 162 163 SnOpSV(ikl,isn) = 1.e-4 * 164 C +... SI: (from 1/10 mm to m) 165 166 167 C +--Contribution of Non Dendritic Snow 168 C + ---------------------------------- 169 170 . ( Sph_OK *( G2snSV(ikl,isn)*G1snSV(ikl,isn)/G1_dSV 171 . +max(demi*G2snSV(ikl,isn),DFcdSV) 172 . *(unun-G1snSV(ikl,isn) /G1_dSV)) 173 174 175 C +--Contribution of Dendritic Snow 176 C + ---------------------------------- 177 178 . +(1.-Sph_OK)*( -G1snSV(ikl,isn)*DDcdSV /G1_dSV 179 . +(unun+G1snSV(ikl,isn) /G1_dSV) 180 . * (G2snSV(ikl,isn)*DScdSV /G1_dSV 181 . +(unun-G2snSV(ikl,isn) /G1_dSV) 182 . *DFcdSV ))) 183 SnOpSV(ikl,isn) = max(zero,SnOpSV(ikl,isn)) 184 185 C + --For outputs (Etienne) 186 C + ------------------------ 187 DOPsnSV(ikl,isn)=SnOpSV(ikl,isn) 188 END DO 1 subroutine SnOptP(jjtime) 2 3 ! +------------------------------------------------------------------------+ 4 ! | MAR/SISVAT SnOptP 12-08-2019 MAR | 5 ! | SubRoutine SnOptP computes the Snow Pack optical Properties | 6 ! +------------------------------------------------------------------------+ 7 ! | | 8 ! | PARAMETERS: knonv: Total Number of columns = | 9 ! | ^^^^^^^^^^ = Total Number of continental Grid Boxes | 10 ! | X Number of Mosaic Cell per Grid Box | 11 ! | | 12 ! | INPUT: isnoSV = total Nb of Ice/Snow Layers | 13 ! | ^^^^^ ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer | 14 ! | | 15 ! | | 16 ! | INPUT: G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer | 17 ! | ^^^^^ G2snSV : Sphericity (>0) or Size of Snow Layer | 18 ! | agsnSV : Snow Age [day] | 19 ! | ro__SV : Snow/Soil Volumic Mass [kg/m3] | 20 ! | eta_SV : Water Content [m3/m3] | 21 ! | rusnSV : Surficial Water Thickness [kg/m2] .OR. [mm] | 22 ! | SWS_SV : Surficial Water Status | 23 ! | dzsnSV : Snow Layer Thickness [m] | 24 ! | | 25 ! | albssv : Soil Albedo [-] | 26 ! | zzsnsv : Snow Pack Thickness [m] | 27 ! | | 28 ! | OUTPUT: albisv : Snow/Ice/Water/Soil Integrated Albedo [-] | 29 ! | ^^^^^^ sEX_sv : Verticaly Integrated Extinction Coefficient | 30 ! | DOPsnSV : Snow Optical diameter [m] | 31 ! | | 32 ! | Internal Variables: | 33 ! | ^^^^^^^^^^^^^^^^^^ | 34 ! | SnOpSV : Snow Grain optical Size [m] | 35 ! | EX1_sv : Integrated Snow Extinction (0.3--0.8micr.m) | 36 ! | EX2_sv : Integrated Snow Extinction (0.8--1.5micr.m) | 37 ! | EX3_sv : Integrated Snow Extinction (1.5--2.8micr.m) | 38 ! | | 39 ! | METHODE: Calcul de la taille optique des grains ? partir de | 40 ! | ^^^^^^^ -leur type decrit par les deux variables descriptives | 41 ! | continues sur la plage -99/+99 passees en appel. | 42 ! | -la taille optique (1/10mm) des etoiles, | 43 ! | des grains fins et | 44 ! | des jeunes faces planes | 45 ! | | 46 ! | METHOD: Computation of the optical diameter of the grains | 47 ! | ^^^^^^ described with the CROCUS formalism G1snSV / G2snSV | 48 ! | | 49 ! | REFERENCE: Brun et al. 1989, J. Glaciol 35 pp. 333--342 | 50 ! | ^^^^^^^^^ Brun et al. 1992, J. Glaciol 38 pp. 13-- 22 | 51 ! | Eric Martin Sept.1996 | 52 ! | | 53 ! | | 54 ! +------------------------------------------------------------------------+ 55 56 57 58 59 ! +--Global Variables 60 ! + ================ 61 62 63 use VARphy 64 use VAR_SV 65 use VARdSV 66 use VARxSV 67 use VARySV 68 use VARtSV 69 USE surface_data, only: iflag_albcalc,correc_alb 70 71 IMPLICIT NONE 72 73 74 ! + -- INPUT 75 integer :: jjtime 76 77 ! +--Internal Variables 78 ! + ================== 79 80 real :: coalb1(knonv) ! weighted Coalbedo, Vis. 81 real :: coalb2(knonv) ! weighted Coalbedo, nIR 1 82 real :: coalb3(knonv) ! weighted Coalbedo, nIR 2 83 real :: coalbm ! weighted Coalbedo, mean 84 real :: sExt_1(knonv) ! Extinction Coeff., Vis. 85 real :: sExt_2(knonv) ! Extinction Coeff., nIR 1 86 real :: sExt_3(knonv) ! Extinction Coeff., nIR 2 87 real :: SnOpSV(knonv, nsno) ! Snow Grain optical Size 88 ! #AG real agesno 89 90 integer :: isn ,ikl ,isn1, i 91 real :: sbeta1,sbeta2,sbeta3,sbeta4,sbeta5 92 real :: AgeMax,AlbMin,HSnoSV,HIceSV,doptmx,SignG1,Sph_OK 93 real :: dalbed,dalbeS,dalbeW 94 real :: bsegal,czemax,csegal,csza 95 real :: RoFrez,DiffRo,SignRo,SnowOK,OpSqrt 96 real :: albSn1,albIc1,a_SnI1,a_SII1 97 real :: albSn2,albIc2,a_SnI2,a_SII2 98 real :: albSn3,albIc3,a_SnI3,a_SII3 99 real :: albSno,albIce,albSnI,albSII,albWIc,albmax 100 real :: doptic,Snow_H,SIce_H,SnownH,SIcenH 101 real :: exarg1,exarg2,exarg3,sign_0,sExt_0 102 real :: albedo_old,albCor 103 real :: ro_ave,dz_ave,minalb 104 real :: l1min,l1max,l2min,l2max,l3min,l3max 105 real :: l6min(6), l6max(6), albSn6(6), a_SII6(6) 106 real :: lmintmp,lmaxtmp,albtmp 107 108 ! +--Local DATA 109 ! + ============ 110 111 ! +--For the computation of the solar irradiance extinction in snow 112 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 113 data sbeta1/0.0192/,sbeta2/0.4000/,sbeta3/0.1098/ 114 data sbeta4/1.0000/ 115 data sbeta5/2.00e1/ 116 117 ! +--Snow Age Maximum (Taiga, e.g. Col de Porte) 118 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 119 data AgeMax /60.0/ 120 ! +... AgeMax: Snow Age Maximum [day] 121 122 data AlbMin /0.94/ 123 ! +... AlbMin: Albedo Minimum / visible (0.3--0.8 micrometers) 124 125 data HSnoSV /0.01/ 126 ! +... HSnoSV: Snow Thickness through witch 127 ! + Albedo is interpolated to Ice Albedo 128 data HIceSV /0.10/ 129 ! +... HIceSV: Snow/Ice Thickness through witch 130 ! + Albedo is interpolated to Soil Albedo 131 data doptmx /2.3e-3/ 132 ! +... doptmx: Maximum optical Diameter (pi * R**2) [m] 133 ! + 134 data czeMAX /0.173648178/ ! 80.deg (Segal et al., 1991 JAS) 135 136 data bsegal /4.00 / ! 137 data albmax /0.99 / ! Albedo max 138 139 ! +-- wavelength limits [m] for each broad band 140 141 data l1min/400.0e-9/,l1max/800.0e-9/ 142 data l2min/800.0e-9/,l2max/1500.0e-9/ 143 data l3min/1500.0e-9/,l3max/2800.0e-9/ 144 145 data l6min/185.0e-9,250.0e-9,400.0e-9, & 146 690.0e-9,1190.0e-9,2380.0e-9/ 147 data l6max/250.0e-9,400.0e-9, & 148 690.0e-9,1190.0e-9,2380.0e-9,4000.0e-9/ 149 150 151 ! +--Snow Grain optical Size 152 ! + ======================= 153 154 DO ikl=1,knonv 155 DO isn=1,max(1,isnoSV(ikl)) 156 157 G2snSV(ikl,isn) = max(epsi,G2snSV(ikl,isn)) 158 ! +... Avoid non physical Values 159 160 SignG1 = sign(unun,G1snSV(ikl,isn)) 161 Sph_OK = max(zero,SignG1) 162 163 SnOpSV(ikl,isn) = 1.e-4 * & 164 ! +... SI: (from 1/10 mm to m) 165 166 167 ! +--Contribution of Non Dendritic Snow 168 ! + ---------------------------------- 169 170 ( Sph_OK *( G2snSV(ikl,isn)*G1snSV(ikl,isn)/G1_dSV & 171 +max(demi*G2snSV(ikl,isn),DFcdSV) & 172 *(unun-G1snSV(ikl,isn) /G1_dSV)) & 173 174 175 ! +--Contribution of Dendritic Snow 176 ! + ---------------------------------- 177 178 +(1.-Sph_OK)*( -G1snSV(ikl,isn)*DDcdSV /G1_dSV & 179 +(unun+G1snSV(ikl,isn) /G1_dSV) & 180 * (G2snSV(ikl,isn)*DScdSV /G1_dSV & 181 +(unun-G2snSV(ikl,isn) /G1_dSV) & 182 *DFcdSV ))) 183 SnOpSV(ikl,isn) = max(zero,SnOpSV(ikl,isn)) 184 185 ! + --For outputs (Etienne) 186 ! + ------------------------ 187 DOPsnSV(ikl,isn)=SnOpSV(ikl,isn) 188 END DO 189 END DO 190 191 192 193 194 ! +--Snow/Ice Albedo 195 ! + =============== 196 197 198 199 ! +--Uppermost effective Snow Layer 200 ! + ------------------------------ 201 202 DO ikl=1,knonv 203 204 isn = max(iun,isnoSV(ikl)) 205 206 SignRo = sign(unun, rocdSV - ro__SV(ikl,isn)) 207 SnowOK = max(zero,SignRo) ! Ice Density Threshold 208 209 OpSqrt = sqrt(SnOpSV(ikl,isn)) 210 211 !CA +--Correction of snow albedo for Antarctica/Greenland 212 !CA -------------------------------------------------- 213 214 215 albCor = correc_alb 216 ! #GL albCor = 1.01 217 ! #AC albCor = 1.01 218 219 220 IF (iflag_albcalc .GE. 1) THEN ! Albedo calculation according to Kokhanovsky and Zege 2004 221 222 dalbed = 0.0 223 doptic=SnOpSV(ikl,isn) 224 csza=coszSV(ikl) 225 226 CALL albedo_kokhanovsky(l1min,l1max,csza,doptic,albSn1) 227 CALL albedo_kokhanovsky(l2min,l2max,csza,doptic,albSn2) 228 CALL albedo_kokhanovsky(l3min,l3max,csza,doptic,albSn3) 229 230 DO i=1,6 231 lmintmp=l6min(i) 232 lmaxtmp=l6max(i) 233 CALL albedo_kokhanovsky(lmintmp,lmaxtmp,csza,doptic,albtmp) 234 albSn6(i)=albtmp 235 ENDDO 236 237 238 ELSE ! Default calculation in SISVAT 239 240 ! Zenith Angle Correction (Segal et al., 1991, JAS 48, p.1025) 241 !--------------------------- (Wiscombe & Warren, dec1980, JAS , p.2723) 242 ! (Warren, 1982, RG , p. 81) 243 ! ------------------------------------------------- 244 245 dalbed = 0.0 246 247 csegal = max(czemax ,coszSV(ikl)) 248 ! #cz dalbeS = ((bsegal+unun)/(unun+2.0*bsegal*csegal) 249 ! #cz. - unun )*0.32 250 ! #cz. / bsegal 251 ! #cz dalbeS = max(dalbeS,zero) 252 ! #cz dalbed = dalbeS * min(1,isnoSV(ikl)) 253 254 dalbeW =(0.64 - csegal )*0.0625 ! Warren 1982, RevGeo, fig.12b 255 ! ! 0.0625 = 5% * 1/0.8, p.81 256 ! ! 0.64 = cos(50) 257 dalbed = dalbeW * min(1,isnoSV(ikl)) 258 !------------------------------------------------------------------------- 259 260 albSn1 = 0.96-1.580*OpSqrt 261 albSn1 = max(albSn1,AlbMin) 262 263 albSn1 = max(albSn1,zero) 264 albSn1 = min(albSn1*albCor,unun) 265 266 albSn2 = 0.95-15.40*OpSqrt 267 albSn2 = max(albSn2,zero) 268 albSn2 = min(albSn2*albCor,unun) 269 270 doptic = min(SnOpSV(ikl,isn),doptmx) 271 albSn3 = 346.3*doptic -32.31*OpSqrt +0.88 272 albSn3 = max(albSn3,zero) 273 albSn3 = min(albSn3*albCor,unun) 274 275 albSn6(1:3)=albSn1 276 albSn6(4:6)=albSn2 277 278 ! !snow albedo corection if wetsnow 279 ! #GL albSn1 = albSn1*max(0.9,(1.-1.5*eta_SV(ikl,isn))) 280 ! #GL albSn2 = albSn2*max(0.9,(1.-1.5*eta_SV(ikl,isn))) 281 ! #GL albSn3 = albSn3*max(0.9,(1.-1.5*eta_SV(ikl,isn))) 282 283 ENDIF 284 285 286 albSno = So1dSV*albSn1 & 287 + So2dSV*albSn2 & 288 + So3dSV*albSn3 289 290 !XF 291 minalb = (aI2dSV + (aI3dSV -aI2dSV) & 292 * (ro__SV(ikl,isn)-ro_Ice)/(roSdSV-ro_Ice)) 293 minalb = min(aI3dSV,max(aI2dSV,minalb)) ! pure/firn albedo 294 295 SnowOK = SnowOK*max(zero,sign(unun, albSno-minalb)) 296 albSn1 = SnowOK*albSn1+(1.0-SnowOK)*max(albSno,minalb) 297 albSn2 = SnowOK*albSn2+(1.0-SnowOK)*max(albSno,minalb) 298 albSn3 = SnowOK*albSn3+(1.0-SnowOK)*max(albSno,minalb) 299 albSn6(:) = SnowOK*albSn6(:)+(1.0-SnowOK)*max(albSno,minalb) 300 301 302 ! + ro < roSdSV | min al > aI3dSV 303 ! + roSdSV < ro < rocdSV | aI2dSV < min al < aI3dSV (fct of density) 304 305 306 ! +--Snow/Ice Pack Thickness 307 ! + ----------------------- 308 309 isn = max(min(isnoSV(ikl) ,ispiSV(ikl)),0) 310 Snow_H = zzsnsv(ikl,isnoSV(ikl))-zzsnsv(ikl,isn) 311 SIce_H = zzsnsv(ikl,isnoSV(ikl)) 312 SnownH = Snow_H / HSnoSV 313 SnownH = min(unun, SnownH) 314 SIcenH = SIce_H / (HIceSV) 315 SIcenH = min(unun, SIcenH) 316 317 ! + The value of SnownH is set to 1 in case of ice lenses above 318 ! + 1m of dry snow (ro<600kg/m3) for using CROCUS albedo 319 320 ! ro_ave = 0. 321 ! dz_ave = 0. 322 ! SnowOK = 1. 323 ! do isn = isnoSV(ikl),1,-1 324 ! ro_ave = ro_ave + ro__SV(ikl,isn) * dzsnSV(ikl,isn) * SnowOK 325 ! dz_ave = dz_ave + dzsnSV(ikl,isn) * SnowOK 326 ! SnowOK = max(zero,sign(unun,1.-dz_ave)) 327 ! enddo 328 329 ! ro_ave = ro_ave / max(dz_ave,epsi) 330 ! SnowOK = max(zero,sign(unun,600.-ro_ave)) 331 ! SnownH = SnowOK + SnownH * (1. - SnowOK) 332 333 ! +--Integrated Snow/Ice Albedo: Case of Water on Bare Ice 334 ! + ----------------------------------------------------- 335 336 isn = max(min(isnoSV(ikl) ,ispiSV(ikl)),0) 337 338 albWIc = aI1dSV-(aI1dSV-aI2dSV) & 339 * exp(-(rusnSV(ikl) & ! 340 * (1. -SWS_SV(ikl) & ! 0 <=> freezing 341 * (1 -min(1,iabs(isn-isnoSV(ikl))))) & ! 1 <=> isn=isnoSV 342 / ru_dSV)**0.50) ! 343 ! albWIc = max(aI1dSV,min(aI2dSV,albWIc+slopSV(ikl)* 344 ! . min(5.,max(1.,dx/10000.)))) 345 346 SignRo = sign(unun,ro_Ice-5.-ro__SV(ikl,isn)) ! RoSN<920kg/m3 347 SnowOK = max(zero,SignRo) 348 349 albWIc = (1. - SnowOK) * albWIc + SnowOK & 350 * (aI2dSV + (aI3dSV -aI2dSV) & 351 * (ro__SV(ikl,isn)-ro_Ice)/(roSdSV-ro_Ice)) 352 353 ! + rocdSV < ro < ro_ice | aI2dSV< al <aI3dSV (fct of density) 354 ! + ro > ro_ice | aI1dSV< al <aI2dSV (fct of superficial water content 355 356 357 ! +--Integrated Snow/Ice Albedo 358 ! + ------------------------------- 359 360 a_SII1 = albWIc +(albSn1-albWIc) *SnownH 361 a_SII1 = min(a_SII1 ,albSn1) 362 363 a_SII2 = albWIc +(albSn2-albWIc) *SnownH 364 a_SII2 = min(a_SII2 ,albSn2) 365 366 a_SII3 = albWIc +(albSn3-albWIc) *SnownH 367 a_SII3 = min(a_SII3 ,albSn3) 368 369 DO i=1,6 370 a_SII6(i) = albWIc +(albSn6(i)-albWIc) *SnownH 371 a_SII6(i) = min(a_SII6(i) ,albSn6(i)) 372 ENDDO 373 374 !c #AG agesno = min(agsnSV(ikl,isn) ,AgeMax) 375 !c #AG a_SII1 = a_SII1 -0.175*agesno/AgeMax 376 ! +... Impurities: Col de Porte Parameter. 377 378 379 380 ! +--Elsewhere Integrated Snow/Ice Albedo 381 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 382 ! #cp ELSE 383 albSII = So1dSV*a_SII1 & 384 + So2dSV*a_SII2 & 385 + So3dSV*a_SII3 386 ! #cp END IF 387 388 389 ! +--Integrated Snow/Ice/Soil Albedo 390 ! + ------------------------------- 391 392 alb1sv(ikl) = albssv(ikl) +(a_SII1-albssv(ikl))*SIcenH 393 alb1sv(ikl) = min(alb1sv(ikl) ,a_SII1) 394 395 alb2sv(ikl) = albssv(ikl) +(a_SII2-albssv(ikl))*SIcenH 396 alb2sv(ikl) = min(alb2sv(ikl) ,a_SII2) 397 398 alb3sv(ikl) = albssv(ikl) +(a_SII3-albssv(ikl))*SIcenH 399 alb3sv(ikl) = min(alb3sv(ikl) ,a_SII3) 400 401 albisv(ikl) = albssv(ikl) +(albSII-albssv(ikl))*SIcenH 402 albisv(ikl) = min(albisv(ikl) ,albSII) 403 404 DO i=1,6 405 alb6sv(ikl,i) = albssv(ikl) +(a_SII6(i)-albssv(ikl))*SIcenH 406 alb6sv(ikl,i) = min(alb6sv(ikl,i) ,a_SII6(i)) 407 ENDDO 408 409 410 ! +--Integrated Snow/Ice/Soil Albedo: Clouds Correction! Greuell & all., 1994 411 ! + --------------------------------------------------! Glob.&t Planet.Change 412 ! ! (9):91-114 413 alb1sv(ikl) = alb1sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH & 414 + dalbed * (1.-cld_SV(ikl)) 415 alb2sv(ikl) = alb2sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH & 416 + dalbed * (1.-cld_SV(ikl)) 417 alb3sv(ikl) = alb3sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH & 418 + dalbed * (1.-cld_SV(ikl)) 419 alb6sv(ikl,:) =alb6sv(ikl,:)+0.05 *(cld_SV(ikl)-0.5)*SIcenH & 420 + dalbed * (1.-cld_SV(ikl)) 421 albisv(ikl) = albisv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH & 422 + dalbed * (1.-cld_SV(ikl)) 423 424 ! +--Integrated Snow/Ice/Soil Albedo: Minimum snow albedo = aI1dSV 425 ! + ------------------------------------------------------------- 426 427 albedo_old = albisv(ikl) 428 albisv(ikl) = max(albisv(ikl),aI1dSV * SIcenH & 429 + albssv(ikl) *(1.0 - SIcenH)) 430 alb1sv(ikl) = alb1sv(ikl) - 1.0/3.0 & ! 33 % 431 * (albedo_old-albisv(ikl)) / So1dSV 432 alb2sv(ikl) = alb2sv(ikl) - 1.0/3.0 & ! 33 % 433 * (albedo_old-albisv(ikl)) / So2dSV 434 alb3sv(ikl) = alb3sv(ikl) - 1.0/3.0 & ! 33 % 435 * (albedo_old-albisv(ikl)) / So3dSV 436 alb6sv(ikl,1:3) = alb6sv(ikl,1:3) - 1.0/6.0 & ! 16 % 437 * (albedo_old-albisv(ikl)) / (So1dSV/3) 438 alb6sv(ikl,4:6) = alb6sv(ikl,4:6) - 1.0/6.0 & ! 16 % 439 * (albedo_old-albisv(ikl)) / (So2dSV/3) 440 441 442 ! +--Integrated Snow/Ice/Soil Albedo: Maximum albedo = 95% 443 ! + ----------------------------------------------------- 444 445 albedo_old = albisv(ikl) 446 albisv(ikl) = min(albisv(ikl),0.95) 447 alb1sv(ikl) = alb1sv(ikl) - 1.0/3.0 & ! 33 % 448 * (albedo_old-albisv(ikl)) / So1dSV 449 alb2sv(ikl) = alb2sv(ikl) - 1.0/3.0 & ! 33 % 450 * (albedo_old-albisv(ikl)) / So2dSV 451 alb3sv(ikl) = alb3sv(ikl) - 1.0/3.0 & ! 33 % 452 * (albedo_old-albisv(ikl)) / So3dSV 453 alb6sv(ikl,1:3) = alb6sv(ikl,1:3) - 1.0/6.0 & ! 16 % 454 * (albedo_old-albisv(ikl)) / (So1dSV/3) 455 alb6sv(ikl,4:6) = alb6sv(ikl,4:6) - 1.0/6.0 & ! 16 % 456 * (albedo_old-albisv(ikl)) / (So2dSV/3) 457 458 459 !Sea Ice/snow permanent-interractive prescription from Nemo 460 !AO_CK 20/02/2020 461 462 ! ! No check if coupling update since MAR and NEMO albedo are too different 463 ! and since MAR albedo is computed on properties that are not in NEMO 464 ! ! prescription for each time step with NEMO values 465 466 ! #AO if (LSmask(ikl) .eq. 0 .and. coupling_ao .eq. .true.) then 467 ! #AO if (AOmask(ikl) .eq. 0) then 468 ! #AO albisv(ikl) = (1.-AOmask(ikl))* albAOsisv(ikl) 469 ! #AO. +(AOmask(ikl)*albisv(ikl)) 470 ! #AO alb1sv(ikl) = (1.-AOmask(ikl))* albAOsisv(ikl) 471 ! #AO. +(AOmask(ikl)*alb1sv(ikl)) 472 ! #AO alb2sv(ikl) = (1.-AOmask(ikl))* albAOsisv(ikl) 473 ! #AO. +(AOmask(ikl)*alb2sv(ikl)) 474 ! #AO alb3sv(ikl) = (1.-AOmask(ikl))* albAOsisv(ikl) 475 ! #AO. +(AOmask(ikl)*alb3sv(ikl)) 476 ! #AO endif 477 ! #AO endif 478 479 480 alb1sv(ikl) = min(max(zero,alb1sv(ikl)),albmax) 481 alb2sv(ikl) = min(max(zero,alb2sv(ikl)),albmax) 482 alb3sv(ikl) = min(max(zero,alb3sv(ikl)),albmax) 483 484 DO i=1,6 485 alb6sv(ikl,i) = min(max(zero,alb6sv(ikl,i)),albmax) 486 ENDDO 487 END DO 488 489 490 ! +--Extinction Coefficient: Exponential Factor 491 ! + ========================================== 492 493 DO ikl=1,knonv 494 sExt_1(ikl) = 1. 495 sExt_2(ikl) = 1. 496 sExt_3(ikl) = 1. 497 sEX_sv(ikl,nsno+1) = 1. 498 499 coalb1(ikl) = (1. -alb1sv(ikl))*So1dSV 500 coalb2(ikl) = (1. -alb2sv(ikl))*So2dSV 501 coalb3(ikl) = (1. -alb3sv(ikl))*So3dSV 502 coalbm = coalb1(ikl) +coalb2(ikl) +coalb3(ikl) 503 coalb1(ikl) = coalb1(ikl) /coalbm 504 coalb2(ikl) = coalb2(ikl) /coalbm 505 coalb3(ikl) = coalb3(ikl) /coalbm 506 END DO 507 508 !XF 509 510 DO isn=nsno,1,-1 511 DO ikl=1,knonv 512 sEX_sv(ikl,isn) = 1.0 513 ! !sEX_sv(ikl,isn) = 0.95 ! if MAR is too warm in summer 189 514 END DO 190 191 192 193 194 C +--Snow/Ice Albedo 195 C + =============== 196 197 198 199 C +--Uppermost effective Snow Layer 200 C + ------------------------------ 201 202 DO ikl=1,knonv 203 204 isn = max(iun,isnoSV(ikl)) 205 206 SignRo = sign(unun, rocdSV - ro__SV(ikl,isn)) 207 SnowOK = max(zero,SignRo) ! Ice Density Threshold 208 209 OpSqrt = sqrt(SnOpSV(ikl,isn)) 210 211 cCA +--Correction of snow albedo for Antarctica/Greenland 212 cCA -------------------------------------------------- 213 214 215 albCor = correc_alb 216 c #GL albCor = 1.01 217 c #AC albCor = 1.01 218 219 220 IF (iflag_albcalc .GE. 1) THEN ! Albedo calculation according to Kokhanovsky and Zege 2004 221 222 dalbed = 0.0 223 doptic=SnOpSV(ikl,isn) 224 csza=coszSV(ikl) 225 226 CALL albedo_kokhanovsky(l1min,l1max,csza,doptic,albSn1) 227 CALL albedo_kokhanovsky(l2min,l2max,csza,doptic,albSn2) 228 CALL albedo_kokhanovsky(l3min,l3max,csza,doptic,albSn3) 229 230 DO i=1,6 231 lmintmp=l6min(i) 232 lmaxtmp=l6max(i) 233 CALL albedo_kokhanovsky(lmintmp,lmaxtmp,csza,doptic,albtmp) 234 albSn6(i)=albtmp 235 ENDDO 236 237 238 ELSE ! Default calculation in SISVAT 239 240 ! Zenith Angle Correction (Segal et al., 1991, JAS 48, p.1025) 241 !--------------------------- (Wiscombe & Warren, dec1980, JAS , p.2723) 242 ! (Warren, 1982, RG , p. 81) 243 ! ------------------------------------------------- 244 245 dalbed = 0.0 246 247 csegal = max(czemax ,coszSV(ikl)) 248 c #cz dalbeS = ((bsegal+unun)/(unun+2.0*bsegal*csegal) 249 c #cz. - unun )*0.32 250 c #cz. / bsegal 251 c #cz dalbeS = max(dalbeS,zero) 252 c #cz dalbed = dalbeS * min(1,isnoSV(ikl)) 253 254 dalbeW =(0.64 - csegal )*0.0625 ! Warren 1982, RevGeo, fig.12b 255 ! 0.0625 = 5% * 1/0.8, p.81 256 ! 0.64 = cos(50) 257 dalbed = dalbeW * min(1,isnoSV(ikl)) 258 !------------------------------------------------------------------------- 259 260 albSn1 = 0.96-1.580*OpSqrt 261 albSn1 = max(albSn1,AlbMin) 262 263 albSn1 = max(albSn1,zero) 264 albSn1 = min(albSn1*albCor,unun) 265 266 albSn2 = 0.95-15.40*OpSqrt 267 albSn2 = max(albSn2,zero) 268 albSn2 = min(albSn2*albCor,unun) 269 270 doptic = min(SnOpSV(ikl,isn),doptmx) 271 albSn3 = 346.3*doptic -32.31*OpSqrt +0.88 272 albSn3 = max(albSn3,zero) 273 albSn3 = min(albSn3*albCor,unun) 274 275 albSn6(1:3)=albSn1 276 albSn6(4:6)=albSn2 277 278 !snow albedo corection if wetsnow 279 c #GL albSn1 = albSn1*max(0.9,(1.-1.5*eta_SV(ikl,isn))) 280 c #GL albSn2 = albSn2*max(0.9,(1.-1.5*eta_SV(ikl,isn))) 281 c #GL albSn3 = albSn3*max(0.9,(1.-1.5*eta_SV(ikl,isn))) 282 283 ENDIF 284 285 286 albSno = So1dSV*albSn1 287 . + So2dSV*albSn2 288 . + So3dSV*albSn3 289 290 cXF 291 minalb = (aI2dSV + (aI3dSV -aI2dSV) 292 . * (ro__SV(ikl,isn)-ro_Ice)/(roSdSV-ro_Ice)) 293 minalb = min(aI3dSV,max(aI2dSV,minalb)) ! pure/firn albedo 294 295 SnowOK = SnowOK*max(zero,sign(unun, albSno-minalb)) 296 albSn1 = SnowOK*albSn1+(1.0-SnowOK)*max(albSno,minalb) 297 albSn2 = SnowOK*albSn2+(1.0-SnowOK)*max(albSno,minalb) 298 albSn3 = SnowOK*albSn3+(1.0-SnowOK)*max(albSno,minalb) 299 albSn6(:) = SnowOK*albSn6(:)+(1.0-SnowOK)*max(albSno,minalb) 300 301 302 c + ro < roSdSV | min al > aI3dSV 303 c + roSdSV < ro < rocdSV | aI2dSV < min al < aI3dSV (fct of density) 304 305 306 C +--Snow/Ice Pack Thickness 307 C + ----------------------- 308 309 isn = max(min(isnoSV(ikl) ,ispiSV(ikl)),0) 310 Snow_H = zzsnsv(ikl,isnoSV(ikl))-zzsnsv(ikl,isn) 311 SIce_H = zzsnsv(ikl,isnoSV(ikl)) 312 SnownH = Snow_H / HSnoSV 313 SnownH = min(unun, SnownH) 314 SIcenH = SIce_H / (HIceSV) 315 SIcenH = min(unun, SIcenH) 316 317 C + The value of SnownH is set to 1 in case of ice lenses above 318 C + 1m of dry snow (ro<600kg/m3) for using CROCUS albedo 319 320 c ro_ave = 0. 321 c dz_ave = 0. 322 c SnowOK = 1. 323 c do isn = isnoSV(ikl),1,-1 324 c ro_ave = ro_ave + ro__SV(ikl,isn) * dzsnSV(ikl,isn) * SnowOK 325 c dz_ave = dz_ave + dzsnSV(ikl,isn) * SnowOK 326 c SnowOK = max(zero,sign(unun,1.-dz_ave)) 327 c enddo 328 329 c ro_ave = ro_ave / max(dz_ave,epsi) 330 c SnowOK = max(zero,sign(unun,600.-ro_ave)) 331 c SnownH = SnowOK + SnownH * (1. - SnowOK) 332 333 C +--Integrated Snow/Ice Albedo: Case of Water on Bare Ice 334 C + ----------------------------------------------------- 335 336 isn = max(min(isnoSV(ikl) ,ispiSV(ikl)),0) 337 338 albWIc = aI1dSV-(aI1dSV-aI2dSV) 339 . * exp(-(rusnSV(ikl) ! 340 . * (1. -SWS_SV(ikl) ! 0 <=> freezing 341 . * (1 -min(1,iabs(isn-isnoSV(ikl))))) ! 1 <=> isn=isnoSV 342 . / ru_dSV)**0.50) ! 343 c albWIc = max(aI1dSV,min(aI2dSV,albWIc+slopSV(ikl)* 344 c . min(5.,max(1.,dx/10000.)))) 345 346 SignRo = sign(unun,ro_Ice-5.-ro__SV(ikl,isn)) ! RoSN<920kg/m3 347 SnowOK = max(zero,SignRo) 348 349 albWIc = (1. - SnowOK) * albWIc + SnowOK 350 . * (aI2dSV + (aI3dSV -aI2dSV) 351 . * (ro__SV(ikl,isn)-ro_Ice)/(roSdSV-ro_Ice)) 352 353 c + rocdSV < ro < ro_ice | aI2dSV< al <aI3dSV (fct of density) 354 c + ro > ro_ice | aI1dSV< al <aI2dSV (fct of superficial water content 355 356 357 C +--Integrated Snow/Ice Albedo 358 C + ------------------------------- 359 360 a_SII1 = albWIc +(albSn1-albWIc) *SnownH 361 a_SII1 = min(a_SII1 ,albSn1) 362 363 a_SII2 = albWIc +(albSn2-albWIc) *SnownH 364 a_SII2 = min(a_SII2 ,albSn2) 365 366 a_SII3 = albWIc +(albSn3-albWIc) *SnownH 367 a_SII3 = min(a_SII3 ,albSn3) 368 369 DO i=1,6 370 a_SII6(i) = albWIc +(albSn6(i)-albWIc) *SnownH 371 a_SII6(i) = min(a_SII6(i) ,albSn6(i)) 372 ENDDO 373 374 cc #AG agesno = min(agsnSV(ikl,isn) ,AgeMax) 375 cc #AG a_SII1 = a_SII1 -0.175*agesno/AgeMax 376 C +... Impurities: Col de Porte Parameter. 377 378 379 380 C +--Elsewhere Integrated Snow/Ice Albedo 381 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 382 c #cp ELSE 383 albSII = So1dSV*a_SII1 384 . + So2dSV*a_SII2 385 . + So3dSV*a_SII3 386 c #cp END IF 387 388 389 C +--Integrated Snow/Ice/Soil Albedo 390 C + ------------------------------- 391 392 alb1sv(ikl) = albssv(ikl) +(a_SII1-albssv(ikl))*SIcenH 393 alb1sv(ikl) = min(alb1sv(ikl) ,a_SII1) 394 395 alb2sv(ikl) = albssv(ikl) +(a_SII2-albssv(ikl))*SIcenH 396 alb2sv(ikl) = min(alb2sv(ikl) ,a_SII2) 397 398 alb3sv(ikl) = albssv(ikl) +(a_SII3-albssv(ikl))*SIcenH 399 alb3sv(ikl) = min(alb3sv(ikl) ,a_SII3) 400 401 albisv(ikl) = albssv(ikl) +(albSII-albssv(ikl))*SIcenH 402 albisv(ikl) = min(albisv(ikl) ,albSII) 403 404 DO i=1,6 405 alb6sv(ikl,i) = albssv(ikl) +(a_SII6(i)-albssv(ikl))*SIcenH 406 alb6sv(ikl,i) = min(alb6sv(ikl,i) ,a_SII6(i)) 407 ENDDO 408 409 410 C +--Integrated Snow/Ice/Soil Albedo: Clouds Correction! Greuell & all., 1994 411 C + --------------------------------------------------! Glob.&t Planet.Change 412 ! (9):91-114 413 alb1sv(ikl) = alb1sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH 414 . + dalbed * (1.-cld_SV(ikl)) 415 alb2sv(ikl) = alb2sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH 416 . + dalbed * (1.-cld_SV(ikl)) 417 alb3sv(ikl) = alb3sv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH 418 . + dalbed * (1.-cld_SV(ikl)) 419 alb6sv(ikl,:) =alb6sv(ikl,:)+0.05 *(cld_SV(ikl)-0.5)*SIcenH 420 . + dalbed * (1.-cld_SV(ikl)) 421 albisv(ikl) = albisv(ikl) + 0.05 *(cld_SV(ikl)-0.5)*SIcenH 422 . + dalbed * (1.-cld_SV(ikl)) 423 424 C +--Integrated Snow/Ice/Soil Albedo: Minimum snow albedo = aI1dSV 425 C + ------------------------------------------------------------- 426 427 albedo_old = albisv(ikl) 428 albisv(ikl) = max(albisv(ikl),aI1dSV * SIcenH 429 . + albssv(ikl) *(1.0 - SIcenH)) 430 alb1sv(ikl) = alb1sv(ikl) - 1.0/3.0 ! 33 % 431 . * (albedo_old-albisv(ikl)) / So1dSV 432 alb2sv(ikl) = alb2sv(ikl) - 1.0/3.0 ! 33 % 433 . * (albedo_old-albisv(ikl)) / So2dSV 434 alb3sv(ikl) = alb3sv(ikl) - 1.0/3.0 ! 33 % 435 . * (albedo_old-albisv(ikl)) / So3dSV 436 alb6sv(ikl,1:3) = alb6sv(ikl,1:3) - 1.0/6.0 ! 16 % 437 . * (albedo_old-albisv(ikl)) / (So1dSV/3) 438 alb6sv(ikl,4:6) = alb6sv(ikl,4:6) - 1.0/6.0 ! 16 % 439 . * (albedo_old-albisv(ikl)) / (So2dSV/3) 440 441 442 C +--Integrated Snow/Ice/Soil Albedo: Maximum albedo = 95% 443 C + ----------------------------------------------------- 444 445 albedo_old = albisv(ikl) 446 albisv(ikl) = min(albisv(ikl),0.95) 447 alb1sv(ikl) = alb1sv(ikl) - 1.0/3.0 ! 33 % 448 . * (albedo_old-albisv(ikl)) / So1dSV 449 alb2sv(ikl) = alb2sv(ikl) - 1.0/3.0 ! 33 % 450 . * (albedo_old-albisv(ikl)) / So2dSV 451 alb3sv(ikl) = alb3sv(ikl) - 1.0/3.0 ! 33 % 452 . * (albedo_old-albisv(ikl)) / So3dSV 453 alb6sv(ikl,1:3) = alb6sv(ikl,1:3) - 1.0/6.0 ! 16 % 454 . * (albedo_old-albisv(ikl)) / (So1dSV/3) 455 alb6sv(ikl,4:6) = alb6sv(ikl,4:6) - 1.0/6.0 ! 16 % 456 . * (albedo_old-albisv(ikl)) / (So2dSV/3) 457 458 459 !Sea Ice/snow permanent-interractive prescription from Nemo 460 !AO_CK 20/02/2020 461 462 ! No check if coupling update since MAR and NEMO albedo are too different 463 ! and since MAR albedo is computed on properties that are not in NEMO 464 ! prescription for each time step with NEMO values 465 466 c #AO if (LSmask(ikl) .eq. 0 .and. coupling_ao .eq. .true.) then 467 c #AO if (AOmask(ikl) .eq. 0) then 468 c #AO albisv(ikl) = (1.-AOmask(ikl))* albAOsisv(ikl) 469 c #AO. +(AOmask(ikl)*albisv(ikl)) 470 c #AO alb1sv(ikl) = (1.-AOmask(ikl))* albAOsisv(ikl) 471 c #AO. +(AOmask(ikl)*alb1sv(ikl)) 472 c #AO alb2sv(ikl) = (1.-AOmask(ikl))* albAOsisv(ikl) 473 c #AO. +(AOmask(ikl)*alb2sv(ikl)) 474 c #AO alb3sv(ikl) = (1.-AOmask(ikl))* albAOsisv(ikl) 475 c #AO. +(AOmask(ikl)*alb3sv(ikl)) 476 c #AO endif 477 c #AO endif 478 479 480 alb1sv(ikl) = min(max(zero,alb1sv(ikl)),albmax) 481 alb2sv(ikl) = min(max(zero,alb2sv(ikl)),albmax) 482 alb3sv(ikl) = min(max(zero,alb3sv(ikl)),albmax) 483 484 DO i=1,6 485 alb6sv(ikl,i) = min(max(zero,alb6sv(ikl,i)),albmax) 486 ENDDO 487 END DO 488 489 490 C +--Extinction Coefficient: Exponential Factor 491 C + ========================================== 492 493 DO ikl=1,knonv 494 sExt_1(ikl) = 1. 495 sExt_2(ikl) = 1. 496 sExt_3(ikl) = 1. 497 sEX_sv(ikl,nsno+1) = 1. 498 499 coalb1(ikl) = (1. -alb1sv(ikl))*So1dSV 500 coalb2(ikl) = (1. -alb2sv(ikl))*So2dSV 501 coalb3(ikl) = (1. -alb3sv(ikl))*So3dSV 502 coalbm = coalb1(ikl) +coalb2(ikl) +coalb3(ikl) 503 coalb1(ikl) = coalb1(ikl) /coalbm 504 coalb2(ikl) = coalb2(ikl) /coalbm 505 coalb3(ikl) = coalb3(ikl) /coalbm 506 END DO 507 508 cXF 509 510 DO isn=nsno,1,-1 511 DO ikl=1,knonv 512 sEX_sv(ikl,isn) = 1.0 513 !sEX_sv(ikl,isn) = 0.95 ! if MAR is too warm in summer 514 END DO 515 END DO 516 517 DO ikl=1,knonv 518 DO isn=max(1,isnoSV(ikl)),1,-1 519 520 SignRo = sign(unun, rocdSV - ro__SV(ikl,isn)) 521 SnowOK = max(zero,SignRo) ! Ice Density Threshold 522 523 RoFrez = 1.e-3 * ro__SV(ikl,isn) * (1.0-eta_SV(ikl,isn)) 524 525 OpSqrt = sqrt(max(epsi,SnOpSV(ikl,isn))) 526 exarg1 = SnowOK *1.e2 *max(sbeta1*RoFrez/OpSqrt,sbeta2) 527 . +(1.0-SnowOK) *sbeta5 528 exarg2 = SnowOK *1.e2 *max(sbeta3*RoFrez/OpSqrt,sbeta4) 529 . +(1.0-SnowOK) *sbeta5 530 exarg3 = SnowOK *1.e2 *sbeta5 531 . +(1.0-SnowOK) *sbeta5 532 533 534 C +--Integrated Extinction of Solar Irradiance (Normalized Value) 535 C + ============================================================ 536 537 sExt_1(ikl) = sExt_1(ikl) 538 . * exp(min(0.0,-exarg1 *dzsnSV(ikl,isn))) 539 sign_0 = sign(unun,eps9 -sExt_1(ikl)) 540 sExt_0 = max(zero,sign_0)*sExt_1(ikl) 541 sExt_1(ikl) = sExt_1(ikl) -sExt_0 542 543 sExt_2(ikl) = sExt_2(ikl) 544 . * exp(min(0.0,-exarg2 *dzsnSV(ikl,isn))) 545 sign_0 = sign(unun,eps9 -sExt_2(ikl)) 546 sExt_0 = max(zero,sign_0)*sExt_2(ikl) 547 sExt_2(ikl) = sExt_2(ikl) -sExt_0 548 549 sExt_3(ikl) = sExt_3(ikl) 550 . * exp(min(0.0,-exarg3 *dzsnSV(ikl,isn))) 551 sign_0 = sign(unun,eps9 -sExt_3(ikl)) 552 sExt_0 = max(zero,sign_0)*sExt_3(ikl) 553 sExt_3(ikl) = sExt_3(ikl) -sExt_0 554 555 sEX_sv(ikl,isn) = coalb1(ikl) * sExt_1(ikl) 556 . + coalb2(ikl) * sExt_2(ikl) 557 . + coalb3(ikl) * sExt_3(ikl) 558 END DO 559 END DO 560 561 DO isn=0,-nsol,-1 562 DO ikl=1,knonv 563 sEX_sv(ikl,isn) = 0.0 564 END DO 565 END DO 566 567 568 return 569 570 571 end 515 END DO 516 517 DO ikl=1,knonv 518 DO isn=max(1,isnoSV(ikl)),1,-1 519 520 SignRo = sign(unun, rocdSV - ro__SV(ikl,isn)) 521 SnowOK = max(zero,SignRo) ! Ice Density Threshold 522 523 RoFrez = 1.e-3 * ro__SV(ikl,isn) * (1.0-eta_SV(ikl,isn)) 524 525 OpSqrt = sqrt(max(epsi,SnOpSV(ikl,isn))) 526 exarg1 = SnowOK *1.e2 *max(sbeta1*RoFrez/OpSqrt,sbeta2) & 527 +(1.0-SnowOK) *sbeta5 528 exarg2 = SnowOK *1.e2 *max(sbeta3*RoFrez/OpSqrt,sbeta4) & 529 +(1.0-SnowOK) *sbeta5 530 exarg3 = SnowOK *1.e2 *sbeta5 & 531 +(1.0-SnowOK) *sbeta5 532 533 534 ! +--Integrated Extinction of Solar Irradiance (Normalized Value) 535 ! + ============================================================ 536 537 sExt_1(ikl) = sExt_1(ikl) & 538 * exp(min(0.0,-exarg1 *dzsnSV(ikl,isn))) 539 sign_0 = sign(unun,eps9 -sExt_1(ikl)) 540 sExt_0 = max(zero,sign_0)*sExt_1(ikl) 541 sExt_1(ikl) = sExt_1(ikl) -sExt_0 542 543 sExt_2(ikl) = sExt_2(ikl) & 544 * exp(min(0.0,-exarg2 *dzsnSV(ikl,isn))) 545 sign_0 = sign(unun,eps9 -sExt_2(ikl)) 546 sExt_0 = max(zero,sign_0)*sExt_2(ikl) 547 sExt_2(ikl) = sExt_2(ikl) -sExt_0 548 549 sExt_3(ikl) = sExt_3(ikl) & 550 * exp(min(0.0,-exarg3 *dzsnSV(ikl,isn))) 551 sign_0 = sign(unun,eps9 -sExt_3(ikl)) 552 sExt_0 = max(zero,sign_0)*sExt_3(ikl) 553 sExt_3(ikl) = sExt_3(ikl) -sExt_0 554 555 sEX_sv(ikl,isn) = coalb1(ikl) * sExt_1(ikl) & 556 + coalb2(ikl) * sExt_2(ikl) & 557 + coalb3(ikl) * sExt_3(ikl) 558 END DO 559 END DO 560 561 DO isn=0,-nsol,-1 562 DO ikl=1,knonv 563 sEX_sv(ikl,isn) = 0.0 564 END DO 565 END DO 566 567 568 return 569 570 571 end subroutine snoptp 572 572 573 573 574 574 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 575 SUBROUTINE albedo_kokhanovsky(lambdamin,lambdamax, 576 .cossza,dopt,albint)577 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++578 ! Authors: Hajar El Habchi El Fenniri, Etienne Vignon, Cecile Agosta579 !Ghislain Picard580 ! Routine that calculates the integrated snow spectral albedo between 581 ! lambdamin and lambdamax following Kokhanisky and Zege 2004,582 ! Scattering optics of snow, Applied Optics, Vol 43, No7 583 ! Code inspired from the snowoptics package of Ghislain Picard:584 ! https://github.com/ghislainp/snowoptics585 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++586 587 588 589 590 591 592 ! Inputs593 !--------594 REALlambdamin ! minimum wavelength for integration [m]595 REAL lambdamax ! maximum wavelength for integration [m]596 REALcossza ! solar zenith angle cosinus597 REALdopt ! optical diameter [m]598 599 !Outputs600 !-------601 REALalbint602 603 ! Local Variables604 !-----------------605 606 REALropt,cosalb,norm,Pas607 REALSSA,alpha,gamm,R,cos30,alb30608 INTEGERi609 610 611 REALB_amp ! amplification factor612 PARAMETER (B_amp=1.6)613 614 REAL g_asy ! asymetry factor615 616 617 INTEGER nlambda ! length of wavelength vector618 619 620 REALlmin621 622 623 REALlmax624 625 626 REALalbmax627 628 629 REALwavelengths(nlambda)630 REALni(nlambda)631 632 DATA wavelengths / 1.85000000e-07, 2.04170854e-07,633 . 2.23341709e-07, 2.42512563e-07,634 . 2.61683417e-07, 2.80854271e-07, 3.00025126e-07, 3.19195980e-07,635 . 3.38366834e-07, 3.57537688e-07, 3.76708543e-07, 3.95879397e-07,636 . 4.15050251e-07, 4.34221106e-07, 4.53391960e-07, 4.72562814e-07,637 . 4.91733668e-07, 5.10904523e-07, 5.30075377e-07, 5.49246231e-07,638 . 5.68417085e-07, 5.87587940e-07, 6.06758794e-07, 6.25929648e-07,639 . 6.45100503e-07, 6.64271357e-07, 6.83442211e-07, 7.02613065e-07,640 . 7.21783920e-07, 7.40954774e-07, 7.60125628e-07, 7.79296482e-07,641 . 7.98467337e-07, 8.17638191e-07, 8.36809045e-07, 8.55979899e-07,642 . 8.75150754e-07, 8.94321608e-07, 9.13492462e-07, 9.32663317e-07,643 . 9.51834171e-07, 9.71005025e-07, 9.90175879e-07, 1.00934673e-06,644 . 1.02851759e-06, 1.04768844e-06, 1.06685930e-06, 1.08603015e-06,645 . 1.10520101e-06, 1.12437186e-06, 1.14354271e-06, 1.16271357e-06,646 . 1.18188442e-06, 1.20105528e-06, 1.22022613e-06, 1.23939698e-06,647 . 1.25856784e-06, 1.27773869e-06, 1.29690955e-06, 1.31608040e-06,648 . 1.33525126e-06, 1.35442211e-06, 1.37359296e-06, 1.39276382e-06,649 . 1.41193467e-06, 1.43110553e-06, 1.45027638e-06, 1.46944724e-06,650 . 1.48861809e-06, 1.50778894e-06, 1.52695980e-06, 1.54613065e-06,651 . 1.56530151e-06, 1.58447236e-06, 1.60364322e-06, 1.62281407e-06,652 . 1.64198492e-06, 1.66115578e-06, 1.68032663e-06, 1.69949749e-06,653 . 1.71866834e-06, 1.73783920e-06, 1.75701005e-06, 1.77618090e-06,654 . 1.79535176e-06, 1.81452261e-06, 1.83369347e-06, 1.85286432e-06,655 . 1.87203518e-06, 1.89120603e-06, 1.91037688e-06, 1.92954774e-06,656 . 1.94871859e-06, 1.96788945e-06, 1.98706030e-06, 2.00623116e-06,657 . 2.02540201e-06, 2.04457286e-06, 2.06374372e-06, 2.08291457e-06,658 . 2.10208543e-06, 2.12125628e-06, 2.14042714e-06, 2.15959799e-06,659 . 2.17876884e-06, 2.19793970e-06, 2.21711055e-06, 2.23628141e-06,660 . 2.25545226e-06, 2.27462312e-06, 2.29379397e-06, 2.31296482e-06,661 . 2.33213568e-06, 2.35130653e-06, 2.37047739e-06, 2.38964824e-06,662 . 2.40881910e-06, 2.42798995e-06, 2.44716080e-06, 2.46633166e-06,663 . 2.48550251e-06, 2.50467337e-06, 2.52384422e-06, 2.54301508e-06,664 . 2.56218593e-06, 2.58135678e-06, 2.60052764e-06, 2.61969849e-06,665 . 2.63886935e-06, 2.65804020e-06, 2.67721106e-06, 2.69638191e-06,666 . 2.71555276e-06, 2.73472362e-06, 2.75389447e-06, 2.77306533e-06,667 . 2.79223618e-06, 2.81140704e-06, 2.83057789e-06, 2.84974874e-06,668 . 2.86891960e-06, 2.88809045e-06, 2.90726131e-06, 2.92643216e-06,669 . 2.94560302e-06, 2.96477387e-06, 2.98394472e-06, 3.00311558e-06,670 . 3.02228643e-06, 3.04145729e-06, 3.06062814e-06, 3.07979899e-06,671 . 3.09896985e-06, 3.11814070e-06, 3.13731156e-06, 3.15648241e-06,672 . 3.17565327e-06, 3.19482412e-06, 3.21399497e-06, 3.23316583e-06,673 . 3.25233668e-06, 3.27150754e-06, 3.29067839e-06, 3.30984925e-06,674 . 3.32902010e-06, 3.34819095e-06, 3.36736181e-06, 3.38653266e-06,675 . 3.40570352e-06, 3.42487437e-06, 3.44404523e-06, 3.46321608e-06,676 . 3.48238693e-06, 3.50155779e-06, 3.52072864e-06, 3.53989950e-06,677 . 3.55907035e-06, 3.57824121e-06, 3.59741206e-06, 3.61658291e-06,678 . 3.63575377e-06, 3.65492462e-06, 3.67409548e-06, 3.69326633e-06,679 . 3.71243719e-06, 3.73160804e-06, 3.75077889e-06, 3.76994975e-06,680 . 3.78912060e-06, 3.80829146e-06, 3.82746231e-06, 3.84663317e-06,681 . 3.86580402e-06, 3.88497487e-06, 3.90414573e-06, 3.92331658e-06,682 .3.94248744e-06, 3.96165829e-06, 3.98082915e-06, 4.00000000e-06/683 684 685 DATA ni /7.74508407e-10, 7.74508407e-10,686 . 7.74508407e-10, 7.74508407e-10,687 . 7.74508407e-10, 7.74508407e-10, 7.74508407e-10, 7.74508407e-10,688 . 6.98381122e-10, 6.23170274e-10, 5.97655992e-10, 5.84106004e-10,689 . 5.44327597e-10, 5.71923510e-10, 6.59723827e-10, 8.05183870e-10,690 . 1.03110161e-09, 1.36680386e-09, 1.85161253e-09, 2.56487751e-09,691 . 3.56462855e-09, 4.89450926e-09, 6.49252022e-09, 9.62029335e-09,692 . 1.32335015e-08, 1.75502184e-08, 2.19240625e-08, 3.03304156e-08,693 . 4.07715972e-08, 5.00414911e-08, 7.09722331e-08, 1.00773751e-07,694 . 1.31427409e-07, 1.42289041e-07, 1.49066787e-07, 2.01558515e-07,695 . 2.99106105e-07, 4.03902086e-07, 4.54292169e-07, 5.21906983e-07,696 . 6.27643362e-07, 9.43955678e-07, 1.33464494e-06, 1.97278315e-06,697 . 2.31801329e-06, 2.20584676e-06, 1.85568138e-06, 1.73395193e-06,698 . 1.73101406e-06, 1.91333936e-06, 2.26413019e-06, 3.23959718e-06,699 . 4.94316963e-06, 6.89378896e-06, 1.02237444e-05, 1.21439656e-05,700 . 1.31567585e-05, 1.33448288e-05, 1.32000000e-05, 1.31608040e-05,701 . 1.33048369e-05, 1.40321464e-05, 1.51526244e-05, 1.80342858e-05,702 . 3.82875736e-05, 1.07325259e-04, 2.11961637e-04, 3.82008054e-04,703 . 5.30897470e-04, 5.29244735e-04, 4.90876605e-04, 4.33905427e-04,704 . 3.77795349e-04, 3.17633099e-04, 2.81078564e-04, 2.57579485e-04,705 . 2.42203100e-04, 2.23789060e-04, 2.04306870e-04, 1.87909255e-04,706 . 1.73117146e-04, 1.61533186e-04, 1.53420328e-04, 1.47578033e-04,707 . 1.42334776e-04, 1.35691466e-04, 1.30495414e-04, 1.36065123e-04,708 . 1.70928821e-04, 2.66389730e-04, 4.80957955e-04, 8.25041961e-04,709 . 1.21654792e-03, 1.50232875e-03, 1.62316078e-03, 1.61649750e-03,710 . 1.53736801e-03, 1.42343711e-03, 1.24459117e-03, 1.02388611e-03,711 . 7.89112523e-04, 5.97204264e-04, 4.57152413e-04, 3.62341259e-04,712 . 2.99128332e-04, 2.57035569e-04, 2.26992203e-04, 2.07110355e-04,713 . 2.05835688e-04, 2.25108810e-04, 2.64262893e-04, 3.23594011e-04,714 . 3.93061117e-04, 4.62789970e-04, 5.19664416e-04, 5.59739628e-04,715 . 5.93476084e-04, 6.22797885e-04, 6.57484833e-04, 6.92849600e-04,716 . 7.26584901e-04, 7.56604648e-04, 7.68009488e-04, 7.65579073e-04,717 . 7.50526164e-04, 7.39809972e-04, 7.55622847e-04, 8.05099514e-04,718 . 9.67279246e-04, 1.16281559e-03, 1.42570247e-03, 2.04986585e-03,719 . 2.93971170e-03, 4.49827711e-03, 7.32537532e-03, 1.18889734e-02,720 . 1.85851805e-02, 2.86242532e-02, 4.34131035e-02, 6.37828307e-02,721 . 9.24145850e-02, 1.35547945e-01, 1.94143245e-01, 2.54542814e-01,722 . 3.02282024e-01, 3.42214181e-01, 3.85475065e-01, 4.38000000e-01,723 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,724 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,725 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,726 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,727 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,728 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,729 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,730 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,731 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,732 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,733 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,734 . 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01,735 .4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01/736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 IF ((wavelengths(i).GE.lambdamin).AND.755 .(wavelengths(i).LT.lambdamax)) THEN756 757 758 759 760 761 762 763 764 END 765 575 SUBROUTINE albedo_kokhanovsky(lambdamin,lambdamax, & 576 cossza,dopt,albint) 577 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 578 ! Authors: Hajar El Habchi El Fenniri, Etienne Vignon, Cecile Agosta 579 ! Ghislain Picard 580 ! Routine that calculates the integrated snow spectral albedo between 581 ! lambdamin and lambdamax following Kokhanisky and Zege 2004, 582 ! Scattering optics of snow, Applied Optics, Vol 43, No7 583 ! Code inspired from the snowoptics package of Ghislain Picard: 584 ! https://github.com/ghislainp/snowoptics 585 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 586 587 588 USE VARphy 589 590 IMPLICIT NONE 591 592 ! Inputs 593 !-------- 594 REAL :: lambdamin ! minimum wavelength for integration [m] 595 REAL :: lambdamax ! maximum wavelength for integration [m] 596 REAL :: cossza ! solar zenith angle cosinus 597 REAL :: dopt ! optical diameter [m] 598 599 !Outputs 600 !------- 601 REAL :: albint 602 603 ! Local Variables 604 !----------------- 605 606 REAL :: ropt,cosalb,norm,Pas 607 REAL :: SSA,alpha,gamm,R,cos30,alb30 608 INTEGER :: i 609 610 611 REAL :: B_amp ! amplification factor 612 PARAMETER (B_amp=1.6) 613 614 REAL :: g_asy ! asymetry factor 615 PARAMETER (g_asy=0.845) 616 617 INTEGER :: nlambda ! length of wavelength vector 618 PARAMETER(nlambda=200) 619 620 REAL :: lmin 621 PARAMETER(lmin=185.0E-9) 622 623 REAL :: lmax 624 PARAMETER(lmax=4000.0E-9) 625 626 REAL :: albmax 627 PARAMETER(albmax=0.99) 628 629 REAL :: wavelengths(nlambda) 630 REAL :: ni(nlambda) 631 632 DATA wavelengths / 1.85000000e-07, 2.04170854e-07, & 633 2.23341709e-07, 2.42512563e-07, & 634 2.61683417e-07, 2.80854271e-07, 3.00025126e-07, 3.19195980e-07, & 635 3.38366834e-07, 3.57537688e-07, 3.76708543e-07, 3.95879397e-07, & 636 4.15050251e-07, 4.34221106e-07, 4.53391960e-07, 4.72562814e-07, & 637 4.91733668e-07, 5.10904523e-07, 5.30075377e-07, 5.49246231e-07, & 638 5.68417085e-07, 5.87587940e-07, 6.06758794e-07, 6.25929648e-07, & 639 6.45100503e-07, 6.64271357e-07, 6.83442211e-07, 7.02613065e-07, & 640 7.21783920e-07, 7.40954774e-07, 7.60125628e-07, 7.79296482e-07, & 641 7.98467337e-07, 8.17638191e-07, 8.36809045e-07, 8.55979899e-07, & 642 8.75150754e-07, 8.94321608e-07, 9.13492462e-07, 9.32663317e-07, & 643 9.51834171e-07, 9.71005025e-07, 9.90175879e-07, 1.00934673e-06, & 644 1.02851759e-06, 1.04768844e-06, 1.06685930e-06, 1.08603015e-06, & 645 1.10520101e-06, 1.12437186e-06, 1.14354271e-06, 1.16271357e-06, & 646 1.18188442e-06, 1.20105528e-06, 1.22022613e-06, 1.23939698e-06, & 647 1.25856784e-06, 1.27773869e-06, 1.29690955e-06, 1.31608040e-06, & 648 1.33525126e-06, 1.35442211e-06, 1.37359296e-06, 1.39276382e-06, & 649 1.41193467e-06, 1.43110553e-06, 1.45027638e-06, 1.46944724e-06, & 650 1.48861809e-06, 1.50778894e-06, 1.52695980e-06, 1.54613065e-06, & 651 1.56530151e-06, 1.58447236e-06, 1.60364322e-06, 1.62281407e-06, & 652 1.64198492e-06, 1.66115578e-06, 1.68032663e-06, 1.69949749e-06, & 653 1.71866834e-06, 1.73783920e-06, 1.75701005e-06, 1.77618090e-06, & 654 1.79535176e-06, 1.81452261e-06, 1.83369347e-06, 1.85286432e-06, & 655 1.87203518e-06, 1.89120603e-06, 1.91037688e-06, 1.92954774e-06, & 656 1.94871859e-06, 1.96788945e-06, 1.98706030e-06, 2.00623116e-06, & 657 2.02540201e-06, 2.04457286e-06, 2.06374372e-06, 2.08291457e-06, & 658 2.10208543e-06, 2.12125628e-06, 2.14042714e-06, 2.15959799e-06, & 659 2.17876884e-06, 2.19793970e-06, 2.21711055e-06, 2.23628141e-06, & 660 2.25545226e-06, 2.27462312e-06, 2.29379397e-06, 2.31296482e-06, & 661 2.33213568e-06, 2.35130653e-06, 2.37047739e-06, 2.38964824e-06, & 662 2.40881910e-06, 2.42798995e-06, 2.44716080e-06, 2.46633166e-06, & 663 2.48550251e-06, 2.50467337e-06, 2.52384422e-06, 2.54301508e-06, & 664 2.56218593e-06, 2.58135678e-06, 2.60052764e-06, 2.61969849e-06, & 665 2.63886935e-06, 2.65804020e-06, 2.67721106e-06, 2.69638191e-06, & 666 2.71555276e-06, 2.73472362e-06, 2.75389447e-06, 2.77306533e-06, & 667 2.79223618e-06, 2.81140704e-06, 2.83057789e-06, 2.84974874e-06, & 668 2.86891960e-06, 2.88809045e-06, 2.90726131e-06, 2.92643216e-06, & 669 2.94560302e-06, 2.96477387e-06, 2.98394472e-06, 3.00311558e-06, & 670 3.02228643e-06, 3.04145729e-06, 3.06062814e-06, 3.07979899e-06, & 671 3.09896985e-06, 3.11814070e-06, 3.13731156e-06, 3.15648241e-06, & 672 3.17565327e-06, 3.19482412e-06, 3.21399497e-06, 3.23316583e-06, & 673 3.25233668e-06, 3.27150754e-06, 3.29067839e-06, 3.30984925e-06, & 674 3.32902010e-06, 3.34819095e-06, 3.36736181e-06, 3.38653266e-06, & 675 3.40570352e-06, 3.42487437e-06, 3.44404523e-06, 3.46321608e-06, & 676 3.48238693e-06, 3.50155779e-06, 3.52072864e-06, 3.53989950e-06, & 677 3.55907035e-06, 3.57824121e-06, 3.59741206e-06, 3.61658291e-06, & 678 3.63575377e-06, 3.65492462e-06, 3.67409548e-06, 3.69326633e-06, & 679 3.71243719e-06, 3.73160804e-06, 3.75077889e-06, 3.76994975e-06, & 680 3.78912060e-06, 3.80829146e-06, 3.82746231e-06, 3.84663317e-06, & 681 3.86580402e-06, 3.88497487e-06, 3.90414573e-06, 3.92331658e-06, & 682 3.94248744e-06, 3.96165829e-06, 3.98082915e-06, 4.00000000e-06/ 683 684 685 DATA ni /7.74508407e-10, 7.74508407e-10, & 686 7.74508407e-10, 7.74508407e-10, & 687 7.74508407e-10, 7.74508407e-10, 7.74508407e-10, 7.74508407e-10, & 688 6.98381122e-10, 6.23170274e-10, 5.97655992e-10, 5.84106004e-10, & 689 5.44327597e-10, 5.71923510e-10, 6.59723827e-10, 8.05183870e-10, & 690 1.03110161e-09, 1.36680386e-09, 1.85161253e-09, 2.56487751e-09, & 691 3.56462855e-09, 4.89450926e-09, 6.49252022e-09, 9.62029335e-09, & 692 1.32335015e-08, 1.75502184e-08, 2.19240625e-08, 3.03304156e-08, & 693 4.07715972e-08, 5.00414911e-08, 7.09722331e-08, 1.00773751e-07, & 694 1.31427409e-07, 1.42289041e-07, 1.49066787e-07, 2.01558515e-07, & 695 2.99106105e-07, 4.03902086e-07, 4.54292169e-07, 5.21906983e-07, & 696 6.27643362e-07, 9.43955678e-07, 1.33464494e-06, 1.97278315e-06, & 697 2.31801329e-06, 2.20584676e-06, 1.85568138e-06, 1.73395193e-06, & 698 1.73101406e-06, 1.91333936e-06, 2.26413019e-06, 3.23959718e-06, & 699 4.94316963e-06, 6.89378896e-06, 1.02237444e-05, 1.21439656e-05, & 700 1.31567585e-05, 1.33448288e-05, 1.32000000e-05, 1.31608040e-05, & 701 1.33048369e-05, 1.40321464e-05, 1.51526244e-05, 1.80342858e-05, & 702 3.82875736e-05, 1.07325259e-04, 2.11961637e-04, 3.82008054e-04, & 703 5.30897470e-04, 5.29244735e-04, 4.90876605e-04, 4.33905427e-04, & 704 3.77795349e-04, 3.17633099e-04, 2.81078564e-04, 2.57579485e-04, & 705 2.42203100e-04, 2.23789060e-04, 2.04306870e-04, 1.87909255e-04, & 706 1.73117146e-04, 1.61533186e-04, 1.53420328e-04, 1.47578033e-04, & 707 1.42334776e-04, 1.35691466e-04, 1.30495414e-04, 1.36065123e-04, & 708 1.70928821e-04, 2.66389730e-04, 4.80957955e-04, 8.25041961e-04, & 709 1.21654792e-03, 1.50232875e-03, 1.62316078e-03, 1.61649750e-03, & 710 1.53736801e-03, 1.42343711e-03, 1.24459117e-03, 1.02388611e-03, & 711 7.89112523e-04, 5.97204264e-04, 4.57152413e-04, 3.62341259e-04, & 712 2.99128332e-04, 2.57035569e-04, 2.26992203e-04, 2.07110355e-04, & 713 2.05835688e-04, 2.25108810e-04, 2.64262893e-04, 3.23594011e-04, & 714 3.93061117e-04, 4.62789970e-04, 5.19664416e-04, 5.59739628e-04, & 715 5.93476084e-04, 6.22797885e-04, 6.57484833e-04, 6.92849600e-04, & 716 7.26584901e-04, 7.56604648e-04, 7.68009488e-04, 7.65579073e-04, & 717 7.50526164e-04, 7.39809972e-04, 7.55622847e-04, 8.05099514e-04, & 718 9.67279246e-04, 1.16281559e-03, 1.42570247e-03, 2.04986585e-03, & 719 2.93971170e-03, 4.49827711e-03, 7.32537532e-03, 1.18889734e-02, & 720 1.85851805e-02, 2.86242532e-02, 4.34131035e-02, 6.37828307e-02, & 721 9.24145850e-02, 1.35547945e-01, 1.94143245e-01, 2.54542814e-01, & 722 3.02282024e-01, 3.42214181e-01, 3.85475065e-01, 4.38000000e-01, & 723 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 724 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 725 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 726 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 727 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 728 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 729 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 730 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 731 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 732 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 733 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 734 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, & 735 4.38000000e-01, 4.38000000e-01, 4.38000000e-01, 4.38000000e-01/ 736 737 738 Pas =(lmax-lmin)/nlambda 739 ropt = dopt/2.0 740 SSA = 3.0/(rhoIce*ropt) 741 cos30 = cos(30.0/180.0*pi) 742 743 744 albint=0. 745 norm=0. 746 747 DO i = 1,nlambda 748 gamm = 4.0 * pi * ni(i) / wavelengths(i) 749 cosalb = 2.0 / (SSA * rhoice) * B_amp * gamm 750 alpha = 16. / 3 * cosalb / (1.0 - g_asy) 751 R = exp(-(alpha**0.5) * 3.0 / 7.0 * (1.0 + 2.0 * cossza)) 752 alb30 = exp(-(alpha**0.5)* 3.0 / 7.0 * (1.0 + 20 * cos30)) 753 754 IF ((wavelengths(i).GE.lambdamin).AND. & 755 (wavelengths(i).LT.lambdamax)) THEN 756 albint=albint+R*Pas ! rectangle integration -> can be improved with trapezintegration 757 norm=norm+Pas 758 ENDIF 759 760 END DO 761 762 albint=max(0.,min(albint/max(norm,1E-10),albmax)) 763 764 END SUBROUTINE albedo_kokhanovsky 765 -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_ts2.f90
r5245 r5246 1 subroutine SISVAT_TS2 2 c #ES. (ETSo_0,ETSo_1,ETSo_d) 3 4 C +------------------------------------------------------------------------+ 5 C | MAR SISVAT_TS2 Mon 16-08-2009 MAR | 6 C| SubRoutine SISVAT_TS2 computes the Soil/Snow temperature and fluxes |7 C| using the same method as in LMDZ for consistency. |8 C| The corresponding LMDZ routines are soil (soil.F90) and calcul_fluxs |9 C | (calcul_fluxs_mod.F90). | 10 C +------------------------------------------------------------------------+ 11 C | | 12 C | | 13 C | PARAMETERS: klonv: Total Number of columns = | 14 C | ^^^^^^^^^^ = Total Number of grid boxes of surface type | 15 C | (land ice for now) | 16 C | | 17 C | INPUT: isnoSV = total Nb of Ice/Snow Layers | 18 C | ^^^^^ sol_SV : Downward Solar Radiation [W/m2] | 19 C | IRd_SV : Surface Downward Longwave Radiation [W/m2] | 20 C | VV__SV : SBL Top Wind Speed [m/s] | 21 C | TaT_SV : SBL Top Temperature [K] | 22 C | QaT_SV : SBL Top Specific Humidity [kg/kg] | 23 C | dzsnSV : Snow Layer Thickness [m] | 24 C | dt__SV : Time Step [s] | 25 C | | 26 C | SoSosv : Absorbed Solar Radiation by Surfac.(Normaliz)[-] | 27 C | Eso_sv : Soil+Snow Emissivity [-] | 28 C | ? rah_sv : Aerodynamic Resistance for Heat [s/m] | 29 C | | 30 C| dz1_SV : "inverse" layer thickness (centered) [1/m] |31 C| dz2_SV : layer thickness (layer above (?)) [m] |32 C| AcoHSV : coefficient for Enthalpy evolution, from atm. |33 C| AcoHSV : coefficient for Enthalpy evolution, from atm. |34 C | AcoQSV : coefficient for Humidity evolution, from atm. | 35 C| BcoQSV : coefficient for Humidity evolution, from atm. |36 C| ps__SV : surface pressure [Pa] |37 C | p1l_SV : 1st atmospheric layer pressure [Pa] | 38 C| cdH_SV : drag coeff Energy (?) |39 C| rsolSV : Radiation balance surface [W/m2] |40 C| lambSV : Coefficient for soil layer geometry [-] |41 C | | 42 C | INPUT / TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 43 C | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] | 44 C | ^^^^^^ rsolSV : Radiation balance surface [W/m2] | 45 C | | 46 C | OUTPUT: IRs_SV : Soil IR Radiation [W/m2] | 47 C | ^^^^^^ HSs_sv : Sensible Heat Flux [W/m2] | 48 C | HLs_sv : Latent Heat Flux [W/m2] | 49 C| TsfnSV : new surface temperature [K] |50 C| Evp_sv : Evaporation [kg/m2] |51 C| dSdTSV : Sensible Heat Flux temp. derivative [W/m2/K] |52 C| dLdTSV : Latent Heat Flux temp. derivative [W/m2/K] |53 C | | 54 C | ? ETSo_0 : Snow/Soil Energy Power, before Forcing [W/m2] | 55 C | ? ETSo_1 : Snow/Soil Energy Power, after Forcing [W/m2] | 56 C | ? ETSo_d : Snow/Soil Energy Power Forcing [W/m2] | 57 C | | 58 C|________________________________________________________________________|59 60 61 62 63 USE VARySV64 USE VARtSV65 USE VARxSV66 67 68 69 70 IMPLICIT NONE71 72 73 C +--Global Variables 74 C + ================ 75 76 77 78 79 !INCLUDE "indicesol.h"80 81 ! include "LMDZphy.inc" 82 83 C +--OUTPUT for Stand Alone NetCDF File 84 C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 85 c #NC real*8 SOsoKL(klonv) ! Absorbed Solar Radiation 86 c #NC real*8 IRsoKL(klonv) ! Absorbed IR Radiation 87 c #NC real*8 HSsoKL(klonv) ! Absorbed Sensible Heat Flux 88 c #NC real*8 HLsoKL(klonv) ! Absorbed Latent Heat Flux 89 c #NC real*8 HLs_KL(klonv) ! Evaporation 90 c #NC real*8 HLv_KL(klonv) ! Transpiration 91 c #NC common/DumpNC/SOsoKL,IRsoKL 92 c #NC . ,HSsoKL,HLsoKL 93 c #NC . ,HLs_KL,HLv_KL 94 95 C +--Internal Variables 96 C + ================== 97 98 integerig,jk,isl99 real mu100 realTsrf(klonv) ! surface temperature as extrapolated from soil101 real mug(klonv) !hj coef top layers102 realztherm_i(klonv),zdz2(klonv,-nsol:nsno),z1s103 realpfluxgrd(klonv), pcapcal(klonv), cal(klonv)104 realbeta(klonv), dif_grnd(klonv)105 realC_coef(klonv,-nsol:nsno),D_coef(klonv,-nsol:nsno)106 107 108 109 110 111 112 113 114 CREAL, PARAMETER :: t_grnd = 271.35, t_coup = 273.15115 CREAL, PARAMETER :: max_eau_sol = 150.0116 117 118 119 REALt_grnd ! not used120 121 REALt_coup ! distinguish evap/sublimation122 123 REALmax_eau_sol124 125 126 127 !write(*,*)'T check'128 ! 129 ! DO ig = 1,knonv 130 ! DO jk = 1,isnoSV(ig) !nsno 131 !IF (TsisSV(ig,jk) <= 1.) THEN !hj check132 !TsisSV(ig,jk) = TsisSV(ig,isnoSV(ig))133 ! ENDIF 134 !135 !IF (TsisSV(ig,jk) <= 1.) THEN !hj check136 !TsisSV(ig,jk) = 273.15137 ! ENDIF 138 !END DO139 ! END DO 140 141 C!=======================================================================142 C! I. First part: corresponds to soil.F90 in LMDZ143 C!=======================================================================144 145 DO ig = 1,knonv146 147 148 C! use arithmetic center between layers to derive dz1 for snow layers for simplicity: 149 dz1_SV(ig,jk)=2./(dzsnSV(ig,jk)+dzsnSV(ig,jk-1))150 151 152 153 154 155 156 157 158 C!-----------------------------------------------------------------------159 C! 1)160 C! Calculation of Cgrf and Dgrd coefficients using soil temperature from 161 C! previous time step.162 C!163 C! These variables are recalculated on the local compressed grid instead 164 C! of saved in restart file.165 C!-----------------------------------------------------------------------166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 &*(1.-D_coef(ig,jk)))182 183 &(TsisSV(ig,jk)*zdz2(ig,jk) &184 &+dz1_SV(ig,jk)*C_coef(ig,jk)) * z1s185 186 187 188 189 C!-----------------------------------------------------------------------190 C! 2)191 C! Computation of the soil temperatures using the Cgrd and Dgrd192 C! coefficient computed above193 C!194 C!-----------------------------------------------------------------------195 C! Extrapolate surface Temperature !hj check196 197 198 ! IF (knonv>0) THEN 199 ! DO ig=1,8 200 !write(*,*)ig,'sisvat: Tsis ',TsisSV(ig,isnoSV(ig))201 !write(*,*)'max-1 ',TsisSV(ig,isnoSV(ig)-1)202 !write(*,*)'max-2 ',TsisSV(ig,isnoSV(ig)-2)203 !write(*,*)'0 ',TsisSV(ig,0)204 !! write(*,*)min(max(isnoSV(ig),0),1),max(1-isnoSV(ig),0)205 !ENDDO206 !END IF207 208 DO ig=1,knonv209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 &*min(max(isnoSV(ig),0),1)+ &228 &((mug(ig)+1)*TsisSV(ig,0)-mug(ig)*TsisSV(ig,-1)) &229 & *max(1-isnoSV(ig),0)230 231 232 233 234 C! Surface temperature235 236 237 &(mug(ig)*(1.-D_coef(ig,isnoSV(ig)))+1.)238 239 240 C! Other temperatures241 242 243 244 &*TsisSV(ig,jk)245 246 247 Cwrite(*,*)ig,'Tsis',TsisSV(ig,0)248 249 CIF (indice == is_sic) THEN250 CDO ig = 1,knonv251 CTsisSV(ig,-nsol) = RTT - 1.8252 CEND DO253 CENDIF254 255 CC !hj new 11 03 2010256 DO ig=1,knonv257 isl = isnoSV(ig)258 C dIRsdT(ig) = Eso_sv(ig)* SteBo * 4. & ! - d(IR)/d(T) 259 C & * Tsf_SV(ig) & !T TsisSV(ig,isl) ! 260 C & * Tsf_SV(ig) & !TsisSV(ig,isl) ! 261 C & * Tsf_SV(ig) !TsisSV(ig,isl) ! 262 C IRs__D(ig) = dIRsdT(ig)* Tsf_SV(ig) * 0.75 !TsisSV(ig,isl) * 0.75 !: 263 dIRsdT(ig) = Eso_sv(ig)* StefBo * 4. & ! - d(IR)/d(T)264 &* TsisSV(ig,isl) & !265 &* TsisSV(ig,isl) & !266 &* TsisSV(ig,isl) & !267 IRs__D(ig) = dIRsdT(ig)* TsisSV(ig,isl) * 0.75 !:268 269 270 C!-----------------------------------------------------------------------271 C! 3)272 C! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil 273 C! temperature274 C!-----------------------------------------------------------------------275 276 277 278 279 280 281 DO ig=1,knonv282 283 284 &*(1.-D_coef(ig,jk)))285 286 &dz1_SV(ig,jk)*C_coef(ig,jk)) * z1s287 288 289 290 291 C!-----------------------------------------------------------------------292 C! 4)293 C! Computation of the surface diffusive flux from ground and294 C! calorific capacity of the ground295 C!-----------------------------------------------------------------------296 297 C! (pfluxgrd)298 299 &(C_coef(ig,isnoSV(ig))+(D_coef(ig,isnoSV(ig))-1.) &300 &*TsisSV(ig,isnoSV(ig)))301 C! (pcapcal)302 303 &(dz2_SV(ig,isnoSV(ig))+dt__SV*(1.-D_coef(ig,isnoSV(ig))) &304 &*dz1_SV(ig,isnoSV(ig)))305 306 307 308 &+ pcapcal(ig) * (TsisSV(ig,isnoSV(ig)) * z1s &309 &- mug(ig)* C_coef(ig,isnoSV(ig)) &310 &- Tsf_SV(ig)) /dt__SV )311 312 313 314 315 316 C!=======================================================================317 C! II. Second part: corresponds to calcul_fluxs_mod.F90 in LMDZ318 C!=======================================================================319 320 321 c#NC HSsoKL=0.322 c#NC HLsoKL=0.323 324 325 326 327 328 329 C! zx_qs = qsat en kg/kg330 C!**********************************************************************x***************331 332 333 334 !write(*,*)'ig',ig,'ps',ps__SV(ig)335 336 337 338 !write(*,*)'ig',ig,'p1l',p1l_SV(ig)339 340 341 342 !write(*,*)'ig',ig,'TaT',TaT_SV(ig)343 344 345 346 !write(*,*)'ig',ig,'QaT',QaT_SV(ig)347 348 349 350 !write(*,*)'ig',ig,'Tsf',Tsf_SV(ig)351 352 353 354 !write(*,*)'ig',ig,'Tsf',Tsf_SV(ig)355 356 357 !IF (Tsrf(ig).LT.1.) THEN358 !! write(*,*)'ig',ig,'Tsrf',Tsrf(ig) 359 !Tsrf(ig)=max(Tsrf(ig),TaT_SV(ig)-20.)360 !ENDIF361 362 !IF (ig.le.3) write(*,*)'ig',ig,'cdH',cdH_SV(ig)363 364 365 ENDDO366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 &/LhvH2O / zx_pkh(ig)381 382 383 384 385 &/ zx_pkh(ig)386 387 388 389 &/ zx_pkh(ig)390 391 392 393 394 Czx_coef(ig) = cdH_SV(ig) * &395 C& (1.0+SQRT(u1lay(ig)**2+v1lay(ig)**2)) * &396 C& p1l_SV(ig)/(RD*t1lay(ig))397 398 &(1.0+VV__SV(ig)) * &399 &p1l_SV(ig)/(RD*TaT_SV(ig))400 401 402 403 404 C! === Calcul de la temperature de surface ===405 C! zx_sl = chaleur latente d'evaporation ou de sublimation406 C!****************************************************************************************407 408 409 410 411 412 413 414 415 416 C! Q417 418 419 &(AcoQSV(ig) - zx_qsat(ig) + &420 &zx_dq_s_dt(ig) * Tsf_SV(ig)) &421 &/ zx_oq(ig)422 423 &/ zx_oq(ig)424 425 C! H426 427 428 429 430 C! surface temperature431 432 & (rsolSV(ig) + zx_mh(ig) + zx_sl(ig) * zx_mq(ig)) &433 &+ dif_grnd(ig) * t_grnd * dt__SV)/ &434 &( 1. - dt__SV * cal(ig)/(RCPD * zx_pkh(ig)) * &435 & (zx_nh(ig) + zx_sl(ig) * zx_nq(ig)) &436 &+ dt__SV * dif_grnd(ig))437 438 !hj rajoute 22 11 2010 tuning...439 440 441 442 443 444 C!== flux_q est le flux de vapeur d'eau: kg/(m**2 s) positive vers bas445 C!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)446 Evp_sv(ig) = - zx_mq(ig) - zx_nq(ig) * TsfnSV(ig)447 448 449 450 C! Derives des flux dF/dTs (W m-2 K-1):451 452 453 454 455 !hj new 11 03 2010 456 457 ! TsisSV(ig,isl) = TsfnSV(ig) 458 IRs_SV(ig) = IRs__D(ig) &!459 & - dIRsdT(ig) * TsfnSV(ig) !TsisSV(ig,isl)? !460 461 ! hj462 c #NC SOsoKL(ig) = sol_SV(ig) * SoSosv(ig) ! Absorbed Sol. 463 c#NC IRsoKL(ig) = IRs_SV(ig) & !Up Surf. IR464 c#NC& + tau_sv(ig) *IRd_SV(ig)*Eso_sv(ig) & !Down Atm IR465 c #NC& -(1.0-tau_sv(ig)) *0.5*IRv_sv(ig) ! Down Veg IR 466 c #NC HLsoKL(ig) = HLs_sv(ig) 467 c #NC HSsoKL(ig) = HSs_sv(ig) 468 c#NC HLs_KL(ig) = Evp_sv(ig)469 470 C! Nouvelle valeure de l'humidite au dessus du sol471 472 473 QaT_SV(ig)=q1_new*(1.-beta(ig)) + beta(ig)*qsat_new474 475 476 477 end ! subroutine SISVAT_TS2 1 subroutine SISVAT_TS2 2 ! #ES. (ETSo_0,ETSo_1,ETSo_d) 3 4 ! +------------------------------------------------------------------------+ 5 ! | MAR SISVAT_TS2 Mon 16-08-2009 MAR | 6 ! | SubRoutine SISVAT_TS2 computes the Soil/Snow temperature and fluxes | 7 ! | using the same method as in LMDZ for consistency. | 8 ! | The corresponding LMDZ routines are soil (soil.F90) and calcul_fluxs | 9 ! | (calcul_fluxs_mod.F90). | 10 ! +------------------------------------------------------------------------+ 11 ! | | 12 ! | | 13 ! | PARAMETERS: klonv: Total Number of columns = | 14 ! | ^^^^^^^^^^ = Total Number of grid boxes of surface type | 15 ! | (land ice for now) | 16 ! | | 17 ! | INPUT: isnoSV = total Nb of Ice/Snow Layers | 18 ! | ^^^^^ sol_SV : Downward Solar Radiation [W/m2] | 19 ! | IRd_SV : Surface Downward Longwave Radiation [W/m2] | 20 ! | VV__SV : SBL Top Wind Speed [m/s] | 21 ! | TaT_SV : SBL Top Temperature [K] | 22 ! | QaT_SV : SBL Top Specific Humidity [kg/kg] | 23 ! | dzsnSV : Snow Layer Thickness [m] | 24 ! | dt__SV : Time Step [s] | 25 ! | | 26 ! | SoSosv : Absorbed Solar Radiation by Surfac.(Normaliz)[-] | 27 ! | Eso_sv : Soil+Snow Emissivity [-] | 28 ! | ? rah_sv : Aerodynamic Resistance for Heat [s/m] | 29 ! | | 30 ! | dz1_SV : "inverse" layer thickness (centered) [1/m] | 31 ! | dz2_SV : layer thickness (layer above (?)) [m] | 32 ! | AcoHSV : coefficient for Enthalpy evolution, from atm. | 33 ! | AcoHSV : coefficient for Enthalpy evolution, from atm. | 34 ! | AcoQSV : coefficient for Humidity evolution, from atm. | 35 ! | BcoQSV : coefficient for Humidity evolution, from atm. | 36 ! | ps__SV : surface pressure [Pa] | 37 ! | p1l_SV : 1st atmospheric layer pressure [Pa] | 38 ! | cdH_SV : drag coeff Energy (?) | 39 ! | rsolSV : Radiation balance surface [W/m2] | 40 ! | lambSV : Coefficient for soil layer geometry [-] | 41 ! | | 42 ! | INPUT / TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 43 ! | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] | 44 ! | ^^^^^^ rsolSV : Radiation balance surface [W/m2] | 45 ! | | 46 ! | OUTPUT: IRs_SV : Soil IR Radiation [W/m2] | 47 ! | ^^^^^^ HSs_sv : Sensible Heat Flux [W/m2] | 48 ! | HLs_sv : Latent Heat Flux [W/m2] | 49 ! | TsfnSV : new surface temperature [K] | 50 ! | Evp_sv : Evaporation [kg/m2] | 51 ! | dSdTSV : Sensible Heat Flux temp. derivative [W/m2/K] | 52 ! | dLdTSV : Latent Heat Flux temp. derivative [W/m2/K] | 53 ! | | 54 ! | ? ETSo_0 : Snow/Soil Energy Power, before Forcing [W/m2] | 55 ! | ? ETSo_1 : Snow/Soil Energy Power, after Forcing [W/m2] | 56 ! | ? ETSo_d : Snow/Soil Energy Power Forcing [W/m2] | 57 ! | | 58 ! |________________________________________________________________________| 59 60 USE VAR_SV 61 USE VARdSV 62 63 USE VARySV 64 USE VARtSV 65 USE VARxSV 66 USE VARphy 67 USE indice_sol_mod 68 69 70 IMPLICIT NONE 71 72 73 ! +--Global Variables 74 ! + ================ 75 76 INCLUDE "YOMCST.h" 77 INCLUDE "YOETHF.h" 78 INCLUDE "FCTTRE.h" 79 ! INCLUDE "indicesol.h" 80 INCLUDE "comsoil.h" 81 ! include "LMDZphy.inc" 82 83 ! +--OUTPUT for Stand Alone NetCDF File 84 ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 85 ! #NC real*8 SOsoKL(klonv) ! Absorbed Solar Radiation 86 ! #NC real*8 IRsoKL(klonv) ! Absorbed IR Radiation 87 ! #NC real*8 HSsoKL(klonv) ! Absorbed Sensible Heat Flux 88 ! #NC real*8 HLsoKL(klonv) ! Absorbed Latent Heat Flux 89 ! #NC real*8 HLs_KL(klonv) ! Evaporation 90 ! #NC real*8 HLv_KL(klonv) ! Transpiration 91 ! #NC common/DumpNC/SOsoKL,IRsoKL 92 ! #NC . ,HSsoKL,HLsoKL 93 ! #NC . ,HLs_KL,HLv_KL 94 95 ! +--Internal Variables 96 ! + ================== 97 98 integer :: ig,jk,isl 99 real :: mu 100 real :: Tsrf(klonv) ! surface temperature as extrapolated from soil 101 real :: mug(klonv) !hj coef top layers 102 real :: ztherm_i(klonv),zdz2(klonv,-nsol:nsno),z1s 103 real :: pfluxgrd(klonv), pcapcal(klonv), cal(klonv) 104 real :: beta(klonv), dif_grnd(klonv) 105 real :: C_coef(klonv,-nsol:nsno),D_coef(klonv,-nsol:nsno) 106 107 REAL, DIMENSION(klonv) :: zx_mh, zx_nh, zx_oh 108 REAL, DIMENSION(klonv) :: zx_mq, zx_nq, zx_oq 109 REAL, DIMENSION(klonv) :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef 110 REAL, DIMENSION(klonv) :: zx_sl, zx_k1 111 REAL, DIMENSION(klonv) :: d_ts 112 REAL :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh 113 REAL :: qsat_new, q1_new 114 ! REAL, PARAMETER :: t_grnd = 271.35, t_coup = 273.15 115 ! REAL, PARAMETER :: max_eau_sol = 150.0 116 REAL, DIMENSION(klonv) :: IRs__D, dIRsdT 117 118 119 REAL :: t_grnd ! not used 120 parameter(t_grnd = 271.35) ! 121 REAL :: t_coup ! distinguish evap/sublimation 122 parameter(t_coup = 273.15) ! 123 REAL :: max_eau_sol 124 parameter(max_eau_sol = 150.0) 125 126 127 ! write(*,*)'T check' 128 ! 129 ! DO ig = 1,knonv 130 ! DO jk = 1,isnoSV(ig) !nsno 131 ! IF (TsisSV(ig,jk) <= 1.) THEN !hj check 132 ! TsisSV(ig,jk) = TsisSV(ig,isnoSV(ig)) 133 ! ENDIF 134 ! 135 ! IF (TsisSV(ig,jk) <= 1.) THEN !hj check 136 ! TsisSV(ig,jk) = 273.15 137 ! ENDIF 138 ! END DO 139 ! END DO 140 141 !!======================================================================= 142 !! I. First part: corresponds to soil.F90 in LMDZ 143 !!======================================================================= 144 145 DO ig = 1,knonv 146 DO jk =1,isnoSV(ig) 147 dz2_SV(ig,jk)=dzsnSV(ig,jk) 148 !! use arithmetic center between layers to derive dz1 for snow layers for simplicity: 149 dz1_SV(ig,jk)=2./(dzsnSV(ig,jk)+dzsnSV(ig,jk-1)) 150 ENDDO 151 ENDDO 152 153 DO ig = 1,knonv 154 ztherm_i(ig) = inertie_lic 155 IF (isnoSV(ig) > 0) ztherm_i(ig) = inertie_sno 156 ENDDO 157 158 !!----------------------------------------------------------------------- 159 !! 1) 160 !! Calculation of Cgrf and Dgrd coefficients using soil temperature from 161 !! previous time step. 162 !! 163 !! These variables are recalculated on the local compressed grid instead 164 !! of saved in restart file. 165 !!----------------------------------------------------------------------- 166 DO ig=1,knonv 167 DO jk=-nsol,nsno 168 zdz2(ig,jk)=dz2_SV(ig,jk)/dt__SV !ptimestep 169 ENDDO 170 ENDDO 171 172 DO ig=1,knonv 173 z1s = zdz2(ig,-nsol)+dz1_SV(ig,-nsol+1) 174 C_coef(ig,-nsol+1)=zdz2(ig,-nsol)*TsisSV(ig,-nsol)/z1s 175 D_coef(ig,-nsol+1)=dz1_SV(ig,-nsol+1)/z1s 176 ENDDO 177 178 DO ig=1,knonv 179 DO jk=-nsol+1,isnoSV(ig)-1,1 180 z1s = 1./(zdz2(ig,jk)+dz1_SV(ig,jk+1)+dz1_SV(ig,jk) & 181 *(1.-D_coef(ig,jk))) 182 C_coef(ig,jk+1)= & 183 (TsisSV(ig,jk)*zdz2(ig,jk) & 184 +dz1_SV(ig,jk)*C_coef(ig,jk)) * z1s 185 D_coef(ig,jk+1)=dz1_SV(ig,jk+1)*z1s 186 ENDDO 187 ENDDO 188 189 !!----------------------------------------------------------------------- 190 !! 2) 191 !! Computation of the soil temperatures using the Cgrd and Dgrd 192 !! coefficient computed above 193 !! 194 !!----------------------------------------------------------------------- 195 !! Extrapolate surface Temperature !hj check 196 mu=1./((2.**1.5-1.)/(2.**(0.5)-1.)-1.) 197 198 ! IF (knonv>0) THEN 199 ! DO ig=1,8 200 ! write(*,*)ig,'sisvat: Tsis ',TsisSV(ig,isnoSV(ig)) 201 ! write(*,*)'max-1 ',TsisSV(ig,isnoSV(ig)-1) 202 ! write(*,*)'max-2 ',TsisSV(ig,isnoSV(ig)-2) 203 ! write(*,*)'0 ',TsisSV(ig,0) 204 !! write(*,*)min(max(isnoSV(ig),0),1),max(1-isnoSV(ig),0) 205 ! ENDDO 206 ! END IF 207 208 DO ig=1,knonv 209 IF (isnoSV(ig).GT.0) THEN 210 IF (isnoSV(ig).GT.1) THEN 211 mug(ig)=1./(1.+dzsnSV(ig,isnoSV(ig)-1)/dzsnSV(ig,isnoSV(ig))) !mu 212 ELSE 213 mug(ig) = 1./(1.+dzsnSV(ig,isnoSV(ig)-1)/dz_dSV(0)) !mu 214 ENDIF 215 ELSE 216 mug(ig) = lambSV 217 ENDIF 218 219 IF (mug(ig) .LE. 0.05) THEN 220 write(*,*)'Attention mu low', mug(ig) 221 ENDIF 222 IF (mug(ig) .GE. 0.98) THEN 223 write(*,*)'Attention mu high', mug(ig) 224 ENDIF 225 226 Tsrf(ig)=(1.5*TsisSV(ig,isnoSV(ig))-0.5*TsisSV(ig,isnoSV(ig)-1))& 227 *min(max(isnoSV(ig),0),1)+ & 228 ((mug(ig)+1)*TsisSV(ig,0)-mug(ig)*TsisSV(ig,-1)) & 229 *max(1-isnoSV(ig),0) 230 ENDDO 231 232 233 234 !! Surface temperature 235 DO ig=1,knonv 236 TsisSV(ig,isnoSV(ig))=(mug(ig)*C_coef(ig,isnoSV(ig))+Tsf_SV(ig))/ & 237 (mug(ig)*(1.-D_coef(ig,isnoSV(ig)))+1.) 238 ENDDO 239 240 !! Other temperatures 241 DO ig=1,knonv 242 DO jk=isnoSV(ig),-nsol+1,-1 243 TsisSV(ig,jk-1)=C_coef(ig,jk)+D_coef(ig,jk) & 244 *TsisSV(ig,jk) 245 ENDDO 246 ENDDO 247 ! write(*,*)ig,'Tsis',TsisSV(ig,0) 248 249 ! IF (indice == is_sic) THEN 250 ! DO ig = 1,knonv 251 ! TsisSV(ig,-nsol) = RTT - 1.8 252 ! END DO 253 ! ENDIF 254 255 !C !hj new 11 03 2010 256 DO ig=1,knonv 257 isl = isnoSV(ig) 258 ! dIRsdT(ig) = Eso_sv(ig)* SteBo * 4. & ! - d(IR)/d(T) 259 ! & * Tsf_SV(ig) & !T TsisSV(ig,isl) ! 260 ! & * Tsf_SV(ig) & !TsisSV(ig,isl) ! 261 ! & * Tsf_SV(ig) !TsisSV(ig,isl) ! 262 ! IRs__D(ig) = dIRsdT(ig)* Tsf_SV(ig) * 0.75 !TsisSV(ig,isl) * 0.75 !: 263 dIRsdT(ig) = Eso_sv(ig)* StefBo * 4. & ! - d(IR)/d(T) 264 * TsisSV(ig,isl) & ! 265 * TsisSV(ig,isl) & ! 266 * TsisSV(ig,isl) & ! 267 IRs__D(ig) = dIRsdT(ig)* TsisSV(ig,isl) * 0.75 !: 268 END DO 269 ! !hj 270 !!----------------------------------------------------------------------- 271 !! 3) 272 !! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil 273 !! temperature 274 !!----------------------------------------------------------------------- 275 DO ig=1,knonv 276 z1s = zdz2(ig,-nsol)+dz1_SV(ig,-nsol+1) 277 C_coef(ig,-nsol+1) = zdz2(ig,-nsol)*TsisSV(ig,-nsol)/z1s 278 D_coef(ig,-nsol+1) = dz1_SV(ig,-nsol+1)/z1s 279 ENDDO 280 281 DO ig=1,knonv 282 DO jk=-nsol+1,isnoSV(ig)-1,1 283 z1s = 1./(zdz2(ig,jk)+dz1_SV(ig,jk+1)+dz1_SV(ig,jk) & 284 *(1.-D_coef(ig,jk))) 285 C_coef(ig,jk+1) = (TsisSV(ig,jk)*zdz2(ig,jk)+ & 286 dz1_SV(ig,jk)*C_coef(ig,jk)) * z1s 287 D_coef(ig,jk+1) = dz1_SV(ig,jk+1)*z1s 288 ENDDO 289 ENDDO 290 291 !!----------------------------------------------------------------------- 292 !! 4) 293 !! Computation of the surface diffusive flux from ground and 294 !! calorific capacity of the ground 295 !!----------------------------------------------------------------------- 296 DO ig=1,knonv 297 !! (pfluxgrd) 298 pfluxgrd(ig) = ztherm_i(ig)*dz1_SV(ig,isnoSV(ig))* & 299 (C_coef(ig,isnoSV(ig))+(D_coef(ig,isnoSV(ig))-1.) & 300 *TsisSV(ig,isnoSV(ig))) 301 !! (pcapcal) 302 pcapcal(ig) = ztherm_i(ig)* & 303 (dz2_SV(ig,isnoSV(ig))+dt__SV*(1.-D_coef(ig,isnoSV(ig))) & 304 *dz1_SV(ig,isnoSV(ig))) 305 z1s = mug(ig)*(1.-D_coef(ig,isnoSV(ig)))+1. 306 pcapcal(ig) = pcapcal(ig)/z1s 307 pfluxgrd(ig) = ( pfluxgrd(ig) & 308 + pcapcal(ig) * (TsisSV(ig,isnoSV(ig)) * z1s & 309 - mug(ig)* C_coef(ig,isnoSV(ig)) & 310 - Tsf_SV(ig)) /dt__SV ) 311 ENDDO 312 313 314 cal(1:knonv) = RCPD / pcapcal(1:knonv) 315 rsolSV(1:knonv) = rsolSV(1:knonv) + pfluxgrd(1:knonv) 316 !!======================================================================= 317 !! II. Second part: corresponds to calcul_fluxs_mod.F90 in LMDZ 318 !!======================================================================= 319 320 Evp_sv = 0. 321 ! #NC HSsoKL=0. 322 ! #NC HLsoKL=0. 323 dSdTSV = 0. 324 dLdTSV = 0. 325 326 beta(:) = 1.0 327 dif_grnd(:) = 0.0 328 329 !! zx_qs = qsat en kg/kg 330 !!**********************************************************************x*************** 331 332 DO ig = 1,knonv 333 IF (ps__SV(ig).LT.1.) THEN 334 ! write(*,*)'ig',ig,'ps',ps__SV(ig) 335 ps__SV(ig)=max(ps__SV(ig),1.e-8) 336 ENDIF 337 IF (p1l_SV(ig).LT.1.) THEN 338 ! write(*,*)'ig',ig,'p1l',p1l_SV(ig) 339 p1l_SV(ig)=max(p1l_SV(ig),1.e-8) 340 ENDIF 341 IF (TaT_SV(ig).LT.180.) THEN 342 ! write(*,*)'ig',ig,'TaT',TaT_SV(ig) 343 TaT_SV(ig)=max(TaT_SV(ig),180.) 344 ENDIF 345 IF (QaT_SV(ig).LT.1.e-8) THEN 346 ! write(*,*)'ig',ig,'QaT',QaT_SV(ig) 347 QaT_SV(ig)=max(QaT_SV(ig),1.e-8) 348 ENDIF 349 IF (Tsf_SV(ig).LT.100.) THEN 350 ! write(*,*)'ig',ig,'Tsf',Tsf_SV(ig) 351 Tsf_SV(ig)=max(Tsf_SV(ig),180.) 352 ENDIF 353 IF (Tsf_SV(ig).GT.500.) THEN 354 ! write(*,*)'ig',ig,'Tsf',Tsf_SV(ig) 355 Tsf_SV(ig)=min(Tsf_SV(ig),400.) 356 ENDIF 357 ! IF (Tsrf(ig).LT.1.) THEN 358 !! write(*,*)'ig',ig,'Tsrf',Tsrf(ig) 359 ! Tsrf(ig)=max(Tsrf(ig),TaT_SV(ig)-20.) 360 ! ENDIF 361 IF (cdH_SV(ig).LT.1.e-10) THEN 362 ! IF (ig.le.3) write(*,*)'ig',ig,'cdH',cdH_SV(ig) 363 cdH_SV(ig)=.5 364 ENDIF 365 ENDDO 366 367 368 DO ig = 1,knonv 369 zx_pkh(ig) = 1. ! (ps__SV(ig)/ps__SV(ig))**RKAPPA 370 IF (thermcep) THEN 371 zdelta=MAX(0.,SIGN(1.,rtt-Tsf_SV(ig))) 372 zcvm5 = R5LES*LhvH2O*(1.-zdelta) + R5IES*LhsH2O*zdelta 373 zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*QaT_SV(ig)) 374 zx_qs= r2es * FOEEW(Tsf_SV(ig),zdelta)/ps__SV(ig) 375 zx_qs=MIN(0.5,zx_qs) 376 ! !write(*,*)'zcor',retv*zx_qs 377 zcor=1./(1.-retv*zx_qs) 378 zx_qs=zx_qs*zcor 379 zx_dq_s_dh = FOEDE(Tsf_SV(ig),zdelta,zcvm5,zx_qs,zcor) & 380 /LhvH2O / zx_pkh(ig) 381 ELSE 382 IF (Tsf_SV(ig).LT.t_coup) THEN 383 zx_qs = qsats(Tsf_SV(ig)) / ps__SV(ig) 384 zx_dq_s_dh = dqsats(Tsf_SV(ig),zx_qs)/LhvH2O & 385 / zx_pkh(ig) 386 ELSE 387 zx_qs = qsatl(Tsf_SV(ig)) / ps__SV(ig) 388 zx_dq_s_dh = dqsatl(Tsf_SV(ig),zx_qs)/LhvH2O & 389 / zx_pkh(ig) 390 ENDIF 391 ENDIF 392 zx_dq_s_dt(ig) = RCPD * zx_pkh(ig) * zx_dq_s_dh 393 zx_qsat(ig) = zx_qs 394 ! zx_coef(ig) = cdH_SV(ig) * & 395 ! & (1.0+SQRT(u1lay(ig)**2+v1lay(ig)**2)) * & 396 ! & p1l_SV(ig)/(RD*t1lay(ig)) 397 zx_coef(ig) = cdH_SV(ig) * & 398 (1.0+VV__SV(ig)) * & 399 p1l_SV(ig)/(RD*TaT_SV(ig)) 400 401 ENDDO 402 403 404 !! === Calcul de la temperature de surface === 405 !! zx_sl = chaleur latente d'evaporation ou de sublimation 406 !!**************************************************************************** 407 408 DO ig = 1,knonv 409 zx_sl(ig) = LhvH2O 410 IF (Tsf_SV(ig) .LT. RTT) zx_sl(ig) = LhsH2O 411 zx_k1(ig) = zx_coef(ig) 412 ENDDO 413 414 415 DO ig = 1,knonv 416 !! Q 417 zx_oq(ig) = 1. - (beta(ig) * zx_k1(ig) * BcoQSV(ig) * dt__SV) 418 zx_mq(ig) = beta(ig) * zx_k1(ig) * & 419 (AcoQSV(ig) - zx_qsat(ig) + & 420 zx_dq_s_dt(ig) * Tsf_SV(ig)) & 421 / zx_oq(ig) 422 zx_nq(ig) = beta(ig) * zx_k1(ig) * (-1. * zx_dq_s_dt(ig)) & 423 / zx_oq(ig) 424 425 !! H 426 zx_oh(ig) = 1. - (zx_k1(ig) * BcoHSV(ig) * dt__SV) 427 zx_mh(ig) = zx_k1(ig) * AcoHSV(ig) / zx_oh(ig) 428 zx_nh(ig) = - (zx_k1(ig) * RCPD * zx_pkh(ig))/ zx_oh(ig) 429 430 !! surface temperature 431 TsfnSV(ig) = (Tsf_SV(ig) + cal(ig)/RCPD * zx_pkh(ig) * dt__SV * & 432 (rsolSV(ig) + zx_mh(ig) + zx_sl(ig) * zx_mq(ig)) & 433 + dif_grnd(ig) * t_grnd * dt__SV)/ & 434 ( 1. - dt__SV * cal(ig)/(RCPD * zx_pkh(ig)) * & 435 (zx_nh(ig) + zx_sl(ig) * zx_nq(ig)) & 436 + dt__SV * dif_grnd(ig)) 437 438 !hj rajoute 22 11 2010 tuning... 439 TsfnSV(ig) = min(RTT+0.02,TsfnSV(ig)) 440 441 d_ts(ig) = TsfnSV(ig) - Tsf_SV(ig) 442 443 444 !!== flux_q est le flux de vapeur d'eau: kg/(m**2 s) positive vers bas 445 !!== flux_t est le flux de cpt (energie sensible): j/(m**2 s) 446 Evp_sv(ig) = - zx_mq(ig) - zx_nq(ig) * TsfnSV(ig) 447 HLs_sv(ig) = - Evp_sv(ig) * zx_sl(ig) 448 HSs_sv(ig) = zx_mh(ig) + zx_nh(ig) * TsfnSV(ig) 449 450 !! Derives des flux dF/dTs (W m-2 K-1): 451 dSdTSV(ig) = zx_nh(ig) 452 dLdTSV(ig) = zx_sl(ig) * zx_nq(ig) 453 454 455 !hj new 11 03 2010 456 isl = isnoSV(ig) 457 ! TsisSV(ig,isl) = TsfnSV(ig) 458 IRs_SV(ig) = IRs__D(ig) & ! 459 - dIRsdT(ig) * TsfnSV(ig) !TsisSV(ig,isl)? ! 460 461 ! hj 462 ! #NC SOsoKL(ig) = sol_SV(ig) * SoSosv(ig) ! Absorbed Sol. 463 ! #NC IRsoKL(ig) = IRs_SV(ig) & !Up Surf. IR 464 ! #NC& + tau_sv(ig) *IRd_SV(ig)*Eso_sv(ig) & !Down Atm IR 465 ! #NC& -(1.0-tau_sv(ig)) *0.5*IRv_sv(ig) ! Down Veg IR 466 ! #NC HLsoKL(ig) = HLs_sv(ig) 467 ! #NC HSsoKL(ig) = HSs_sv(ig) 468 ! #NC HLs_KL(ig) = Evp_sv(ig) 469 470 !! Nouvelle valeure de l'humidite au dessus du sol 471 qsat_new=zx_qsat(ig) + zx_dq_s_dt(ig) * d_ts(ig) 472 q1_new = AcoQSV(ig) - BcoQSV(ig)* Evp_sv(ig)*dt__SV 473 QaT_SV(ig)=q1_new*(1.-beta(ig)) + beta(ig)*qsat_new 474 475 ENDDO 476 477 end subroutine sisvat_ts2 -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_tso.f90
r5245 r5246 1 2 3 4 5 subroutine SISVAT_TSo 6 ! #e1. (ETSo_0,ETSo_1,ETSo_d) 7 8 C +------------------------------------------------------------------------+ 9 C | MAR SISVAT_TSo 06-10-2020 MAR | 10 C | SubRoutine SISVAT_TSo computes the Soil/Snow Energy Balance | 11 C +------------------------------------------------------------------------+ 12 C | | 13 C | PARAMETERS: knonv: Total Number of columns = | 14 C | ^^^^^^^^^^ = Total Number of continental grid boxes | 15 C | X Number of Mosaic Cell per grid box | 16 C | | 17 C | INPUT: isotSV = 0,...,11: Soil Type | 18 C | ^^^^^ 0: Water, Solid or Liquid | 19 C | isnoSV = total Nb of Ice/Snow Layers | 20 C | dQa_SV = Limitation of Water Vapor Turbulent Flux | 21 C | | 22 C | INPUT: sol_SV : Downward Solar Radiation [W/m2] | 23 C | ^^^^^ IRd_SV : Surface Downward Longwave Radiation [W/m2] | 24 C | za__SV : SBL Top Height [m] | 25 C | VV__SV : SBL Top Wind Speed [m/s] | 26 C | TaT_SV : SBL Top Temperature [K] | 27 C | rhT_SV : SBL Top Air Density [kg/m3] | 28 C | QaT_SV : SBL Top Specific Humidity [kg/kg] | 29 C | LSdzsv : Vertical Discretization Factor [-] | 30 C | = 1. Soil | 31 C | = 1000. Ocean | 32 C | dzsnSV : Snow Layer Thickness [m] | 33 C | ro__SV : Snow/Soil Volumic Mass [kg/m3] | 34 C | eta_SV : Soil Water Content [m3/m3] | 35 C | dt__SV : Time Step [s] | 36 C | | 37 C | SoSosv : Absorbed Solar Radiation by Surfac.(Normaliz)[-] | 38 C | Eso_sv : Soil+Snow Emissivity [-] | 39 C | rah_sv : Aerodynamic Resistance for Heat [s/m] | 40 C | Lx_H2O : Latent Heat of Vaporization/Sublimation [J/kg] | 41 C | sEX_sv : Verticaly Integrated Extinction Coefficient [-] | 42 C | | 43 C | INPUT / TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 44 C | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] | 45 C | ^^^^^^ | 46 C | | 47 C | OUTPUT: IRs_SV : Soil IR Radiation [W/m2] | 48 C | ^^^^^^ HSs_sv : Sensible Heat Flux [W/m2] | 49 C | HLs_sv : Latent Heat Flux [W/m2] | 50 C | ETSo_0 : Snow/Soil Energy Power, before Forcing [W/m2] | 51 C | ETSo_1 : Snow/Soil Energy Power, after Forcing [W/m2] | 52 C | ETSo_d : Snow/Soil Energy Power Forcing [W/m2] | 53 C | | 54 C | Internal Variables: | 55 C | ^^^^^^^^^^^^^^^^^^ | 56 C | | 57 C | METHOD: NO Skin Surface Temperature | 58 C | ^^^^^^ Semi-Implicit Crank Nicholson Scheme | 59 C | | 60 C | # OPTIONS: #E0: Energy Budget Verification | 61 C | # ^^^^^^^ #kd: KDsvat Option:NO Flux Limitor on HL | 62 C | # #KD: KDsvat Option:Explicit Formulation of HL | 63 C | # #NC: OUTPUT for Stand Alone NetCDF File | 64 C | | 65 C +------------------------------------------------------------------------+ 66 67 68 69 70 C +--Global Variables 71 C + ================ 72 73 use VARphy 74 use VAR_SV 75 use VARdSV 76 use VARxSV 77 use VARySV 78 use VARtSV 79 use VAR0SV 80 81 82 IMPLICIT NONE 83 84 85 C +--OUTPUT 86 C + ------ 87 88 ! #e1 real ETSo_0(knonv) ! Soil/Snow Power, before Forcing 89 ! #e1 real ETSo_1(knonv) ! Soil/Snow Power, after Forcing 90 ! #e1 real ETSo_d(knonv) ! Soil/Snow Power, Forcing 91 92 93 C +--Internal Variables 94 C + ================== 95 96 integer ikl ,isl ,jsl ,ist ! 97 integer ist__s,ist__w ! Soil/Water Body Identifier 98 integer islsgn ! Soil/Snow Surfac.Identifier 99 real eps__3 ! Arbitrary Low Number 100 real etaMid,psiMid ! Layer Interface's Humidity 101 real mu_eta ! Soil thermal Conductivity 102 real mu_exp ! arg Soil thermal Conductivity 103 real mu_min ! Min Soil thermal Conductivity 104 real mu_max ! Max Soil thermal Conductivity 105 real mu_sno(knonv),mu_aux ! Snow thermal Conductivity 106 real mu__dz(knonv,-nsol:nsno+1) ! mu_(eta,sno) / dz 107 real dtC_sv(knonv,-nsol:nsno) ! dt / C 108 real IRs__D(knonv) ! UpwardIR Previous Iter.Contr. 109 real dIRsdT(knonv) ! UpwardIR T Derivat. 110 real f_HSHL(knonv) ! Factor common to HS and HL 111 real dRidTs(knonv) ! d(Rib)/d(Ts) 112 real HS___D(knonv) ! Sensible Heat Flux Atm.Contr. 113 real f___HL(knonv) ! 114 real HL___D(knonv) ! Latent Heat Flux Atm.Contr. 115 REAL TSurf0(knonv),dTSurf ! Previous Surface Temperature 116 real qsatsg(knonv) !,den_qs,arg_qs ! Soil Saturat. Spec. Humidity 117 real dqs_dT(knonv) ! d(qsatsg)/dTv 118 real Psi( knonv) ! 1st Soil Layer Water Potential 119 real RHuSol(knonv) ! Soil Surface Relative Humidity 120 real etaSol ! Soil Surface Humidity 121 real d__eta ! Soil Surface Humidity Increm. 122 real Elem_A,Elem_C ! Diagonal Coefficients 123 real Diag_A(knonv,-nsol:nsno) ! A Diagonal 124 real Diag_B(knonv,-nsol:nsno) ! B Diagonal 125 real Diag_C(knonv,-nsol:nsno) ! C Diagonal 126 real Term_D(knonv,-nsol:nsno) ! Independant Term 127 real Aux__P(knonv,-nsol:nsno) ! P Auxiliary Variable 128 real Aux__Q(knonv,-nsol:nsno) ! Q Auxiliary Variable 129 real Ts_Min,Ts_Max ! Temperature Limits 130 ! #e1 real Exist0 ! Existing Layer Switch 131 real psat_wat, psat_ice, sp ! computation of qsat 132 133 integer nt_srf,it_srf,itEuBk ! HL: Surface Scheme 134 parameter(nt_srf=10) ! 10 before 135 real agpsrf,xgpsrf,dt_srf,dt_ver ! 136 real etaBAK(knonv) ! 137 real etaNEW(knonv) ! 138 real etEuBk(knonv) ! 139 real fac_dt(knonv),faceta(knonv) ! 140 real PsiArg(knonv),SHuSol(knonv) ! 141 142 143 144 C +--Internal DATA 145 C + ============= 146 147 data eps__3 / 1.e-3 / ! Arbitrary Low Number 148 data mu_exp / -0.4343 / ! Soil Thermal Conductivity 149 data mu_min / 0.172 / ! Min Soil Thermal Conductivity 150 data mu_max / 2.000 / ! Max Soil Thermal Conductivity 151 data Ts_Min / 175. / ! Temperature Minimum 152 data Ts_Max / 300. / ! Temperature Acceptable Maximum 153 C + ! including Snow Melt Energy 154 155 C +-- Initilialisation of local arrays 156 C + ================================ 1 2 3 4 5 subroutine SISVAT_TSo 6 ! #e1. (ETSo_0,ETSo_1,ETSo_d) 7 8 ! +------------------------------------------------------------------------+ 9 ! | MAR SISVAT_TSo 06-10-2020 MAR | 10 ! | SubRoutine SISVAT_TSo computes the Soil/Snow Energy Balance | 11 ! +------------------------------------------------------------------------+ 12 ! | | 13 ! | PARAMETERS: knonv: Total Number of columns = | 14 ! | ^^^^^^^^^^ = Total Number of continental grid boxes | 15 ! | X Number of Mosaic Cell per grid box | 16 ! | | 17 ! | INPUT: isotSV = 0,...,11: Soil Type | 18 ! | ^^^^^ 0: Water, Solid or Liquid | 19 ! | isnoSV = total Nb of Ice/Snow Layers | 20 ! | dQa_SV = Limitation of Water Vapor Turbulent Flux | 21 ! | | 22 ! | INPUT: sol_SV : Downward Solar Radiation [W/m2] | 23 ! | ^^^^^ IRd_SV : Surface Downward Longwave Radiation [W/m2] | 24 ! | za__SV : SBL Top Height [m] | 25 ! | VV__SV : SBL Top Wind Speed [m/s] | 26 ! | TaT_SV : SBL Top Temperature [K] | 27 ! | rhT_SV : SBL Top Air Density [kg/m3] | 28 ! | QaT_SV : SBL Top Specific Humidity [kg/kg] | 29 ! | LSdzsv : Vertical Discretization Factor [-] | 30 ! | = 1. Soil | 31 ! | = 1000. Ocean | 32 ! | dzsnSV : Snow Layer Thickness [m] | 33 ! | ro__SV : Snow/Soil Volumic Mass [kg/m3] | 34 ! | eta_SV : Soil Water Content [m3/m3] | 35 ! | dt__SV : Time Step [s] | 36 ! | | 37 ! | SoSosv : Absorbed Solar Radiation by Surfac.(Normaliz)[-] | 38 ! | Eso_sv : Soil+Snow Emissivity [-] | 39 ! | rah_sv : Aerodynamic Resistance for Heat [s/m] | 40 ! | Lx_H2O : Latent Heat of Vaporization/Sublimation [J/kg] | 41 ! | sEX_sv : Verticaly Integrated Extinction Coefficient [-] | 42 ! | | 43 ! | INPUT / TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 44 ! | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] | 45 ! | ^^^^^^ | 46 ! | | 47 ! | OUTPUT: IRs_SV : Soil IR Radiation [W/m2] | 48 ! | ^^^^^^ HSs_sv : Sensible Heat Flux [W/m2] | 49 ! | HLs_sv : Latent Heat Flux [W/m2] | 50 ! | ETSo_0 : Snow/Soil Energy Power, before Forcing [W/m2] | 51 ! | ETSo_1 : Snow/Soil Energy Power, after Forcing [W/m2] | 52 ! | ETSo_d : Snow/Soil Energy Power Forcing [W/m2] | 53 ! | | 54 ! | Internal Variables: | 55 ! | ^^^^^^^^^^^^^^^^^^ | 56 ! | | 57 ! | METHOD: NO Skin Surface Temperature | 58 ! | ^^^^^^ Semi-Implicit Crank Nicholson Scheme | 59 ! | | 60 ! | # OPTIONS: #E0: Energy Budget Verification | 61 ! | # ^^^^^^^ #kd: KDsvat Option:NO Flux Limitor on HL | 62 ! | # #KD: KDsvat Option:Explicit Formulation of HL | 63 ! | # #NC: OUTPUT for Stand Alone NetCDF File | 64 ! | | 65 ! +------------------------------------------------------------------------+ 66 67 68 69 70 ! +--Global Variables 71 ! + ================ 72 73 use VARphy 74 use VAR_SV 75 use VARdSV 76 use VARxSV 77 use VARySV 78 use VARtSV 79 use VAR0SV 80 81 82 IMPLICIT NONE 83 84 85 ! +--OUTPUT 86 ! + ------ 87 88 ! #e1 real ETSo_0(knonv) ! Soil/Snow Power, before Forcing 89 ! #e1 real ETSo_1(knonv) ! Soil/Snow Power, after Forcing 90 ! #e1 real ETSo_d(knonv) ! Soil/Snow Power, Forcing 91 92 93 ! +--Internal Variables 94 ! + ================== 95 96 integer :: ikl ,isl ,jsl ,ist ! 97 integer :: ist__s,ist__w ! Soil/Water Body Identifier 98 integer :: islsgn ! Soil/Snow Surfac.Identifier 99 real :: eps__3 ! Arbitrary Low Number 100 real :: etaMid,psiMid ! Layer Interface's Humidity 101 real :: mu_eta ! Soil thermal Conductivity 102 real :: mu_exp ! arg Soil thermal Conductivity 103 real :: mu_min ! Min Soil thermal Conductivity 104 real :: mu_max ! Max Soil thermal Conductivity 105 real :: mu_sno(knonv),mu_aux ! Snow thermal Conductivity 106 real :: mu__dz(knonv,-nsol:nsno+1) ! mu_(eta,sno) / dz 107 real :: dtC_sv(knonv,-nsol:nsno) ! dt / C 108 real :: IRs__D(knonv) ! UpwardIR Previous Iter.Contr. 109 real :: dIRsdT(knonv) ! UpwardIR T Derivat. 110 real :: f_HSHL(knonv) ! Factor common to HS and HL 111 real :: dRidTs(knonv) ! d(Rib)/d(Ts) 112 real :: HS___D(knonv) ! Sensible Heat Flux Atm.Contr. 113 real :: f___HL(knonv) ! 114 real :: HL___D(knonv) ! Latent Heat Flux Atm.Contr. 115 REAL :: TSurf0(knonv),dTSurf ! Previous Surface Temperature 116 real :: qsatsg(knonv) !,den_qs,arg_qs ! Soil Saturat. Spec. Humidity 117 real :: dqs_dT(knonv) ! d(qsatsg)/dTv 118 real :: Psi( knonv) ! 1st Soil Layer Water Potential 119 real :: RHuSol(knonv) ! Soil Surface Relative Humidity 120 real :: etaSol ! Soil Surface Humidity 121 real :: d__eta ! Soil Surface Humidity Increm. 122 real :: Elem_A,Elem_C ! Diagonal Coefficients 123 real :: Diag_A(knonv,-nsol:nsno) ! A Diagonal 124 real :: Diag_B(knonv,-nsol:nsno) ! B Diagonal 125 real :: Diag_C(knonv,-nsol:nsno) ! C Diagonal 126 real :: Term_D(knonv,-nsol:nsno) ! Independant Term 127 real :: Aux__P(knonv,-nsol:nsno) ! P Auxiliary Variable 128 real :: Aux__Q(knonv,-nsol:nsno) ! Q Auxiliary Variable 129 real :: Ts_Min,Ts_Max ! Temperature Limits 130 ! #e1 real Exist0 ! Existing Layer Switch 131 real :: psat_wat, psat_ice, sp ! computation of qsat 132 133 integer :: nt_srf,it_srf,itEuBk ! HL: Surface Scheme 134 parameter(nt_srf=10) ! 10 before 135 real :: agpsrf,xgpsrf,dt_srf,dt_ver ! 136 real :: etaBAK(knonv) ! 137 real :: etaNEW(knonv) ! 138 real :: etEuBk(knonv) ! 139 real :: fac_dt(knonv),faceta(knonv) ! 140 real :: PsiArg(knonv),SHuSol(knonv) ! 141 142 143 144 ! +--Internal DATA 145 ! + ============= 146 147 data eps__3 / 1.e-3 / ! Arbitrary Low Number 148 data mu_exp / -0.4343 / ! Soil Thermal Conductivity 149 data mu_min / 0.172 / ! Min Soil Thermal Conductivity 150 data mu_max / 2.000 / ! Max Soil Thermal Conductivity 151 data Ts_Min / 175. / ! Temperature Minimum 152 data Ts_Max / 300. / ! Temperature Acceptable Maximum 153 ! + ! including Snow Melt Energy 154 155 ! +-- Initilialisation of local arrays 156 ! + ================================ 157 DO ikl=1,knonv 158 159 mu_sno(ikl)=0. 160 mu__dz(ikl,:)=0. 161 dtC_sv(ikl,:)=0. 162 IRs__D(ikl)=0. 163 dIRsdT(ikl)=0. 164 f_HSHL(ikl)=0. 165 dRidTs(ikl)=0. 166 HS___D(ikl)=0. 167 f___HL(ikl)=0. 168 HL___D(ikl)=0. 169 TSurf0(ikl)=0. 170 qsatsg(ikl)=0. 171 dqs_dT(ikl)=0. 172 Psi(ikl)=0. 173 RHuSol(ikl)=0. 174 Diag_A(ikl,:)=0. 175 Diag_B(ikl,:)=0. 176 Diag_C(ikl,:)=0. 177 Term_D(ikl,:)=0. 178 Aux__P(ikl,:)=0. 179 Aux__Q(ikl,:)=0. 180 etaBAK(ikl)=0. 181 etaNEW(ikl)=0. 182 etEuBk(ikl)=0. 183 fac_dt(ikl)=0. 184 faceta(ikl)=0. 185 PsiArg(ikl)=0. 186 SHuSol(ikl)=0. 187 188 END DO 189 190 191 192 ! +--Heat Conduction Coefficient (zero in the Layers over the highest one) 193 ! + =========================== 194 ! + ---------------- isl eta_SV, rho C (isl) 195 ! + 196 ! +--Soil ++++++++++++++++ etaMid, mu (isl) 197 ! + ---- 198 ! + ---------------- isl-1 eta_SV, rho C (isl-1) 199 isl=-nsol 200 DO ikl=1,knonv 201 202 mu__dz(ikl,isl) = 0. 203 204 dtC_sv(ikl,isl) = dtz_SV2(isl) * dt__SV & ! dt / (dz X rho C) 205 /((rocsSV(isotSV(ikl)) & ! [s / (m.J/m3/K)] 206 +rcwdSV*eta_SV(ikl,isl)) & ! 207 *LSdzsv(ikl) ) ! 208 END DO 209 DO isl=-nsol+1,0 210 DO ikl=1,knonv 211 ist = isotSV(ikl) ! Soil Type 212 ist__s = min(ist, 1) ! 1 => Soil 213 ist__w = 1 - ist__s ! 1 => Water Body 214 215 etaMid = 0.5*(dz_dSV(isl-1)*eta_SV(ikl,isl-1) & ! eta at layers 216 +dz_dSV(isl) *eta_SV(ikl,isl) ) & ! interface 217 /dzmiSV(isl) ! LSdzsv implicit ! 218 etaMid = max(etaMid,epsi) 219 psiMid = psidSV(ist) & 220 *(etadSV(ist)/etaMid)**bCHdSV(ist) 221 mu_eta = 3.82 *(psiMid)**mu_exp ! Soil Thermal 222 mu_eta = min(max(mu_eta, mu_min), mu_max) ! Conductivity 223 ! + ! DR97 eq.3.31 224 mu_eta = ist__s *mu_eta +ist__w * vK_dSV ! Water Bodies 225 ! + ! Correction 226 mu__dz(ikl,isl) = mu_eta/(dzmiSV(isl) & ! 227 *LSdzsv(ikl)) ! 228 229 dtC_sv(ikl,isl) = dtz_SV2(isl)* dt__SV & ! dt / (dz X rho C) 230 /((rocsSV(isotSV(ikl)) & ! 231 +rcwdSV*eta_SV(ikl,isl)) & ! 232 *LSdzsv(ikl) ) ! 233 END DO 234 END DO 235 236 237 ! +--Soil/Snow Interface 238 ! + ------------------- 239 240 ! +--Soil Contribution 241 ! + ^^^^^^^^^^^^^^^^^ 242 isl=1 243 DO ikl=1,knonv 244 ist = isotSV(ikl) ! Soil Type 245 ist__s = min(ist, 1) ! 1 => Soil 246 ist__w = 1 - ist__s ! 1 => Water Body 247 psiMid = psidSV(ist) ! Snow => Saturation 248 mu_eta = 3.82 *(psiMid)**mu_exp ! Soil Thermal 249 mu_eta = min(max(mu_eta, mu_min), mu_max) ! Conductivity 250 ! + ! DR97 eq.3.31 251 mu_eta = ist__s *mu_eta +ist__w * vK_dSV ! Water Bodies 252 253 ! +--Snow Contribution 254 ! + ^^^^^^^^^^^^^^^^^ 255 mu_sno(ikl) = CdidSV & ! 256 *(ro__SV(ikl,isl) /ro_Wat) ** 1.88 ! 257 mu_sno(ikl) = max(epsi,mu_sno(ikl)) ! 258 ! +... mu_sno : Snow Heat Conductivity Coefficient [Wm/K] 259 ! + (Yen 1981, CRREL Rep., 81-10) 260 261 ! +--Combined Heat Conductivity 262 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 263 mu__dz(ikl,isl) = 2./(dzsnSV(ikl,isl ) & ! Combined Heat 264 /mu_sno(ikl) & ! Conductivity 265 +LSdzsv(ikl) & ! 266 *dz_dSV( isl-1)/mu_eta) ! Coefficient 267 268 ! +--Inverted Heat Capacity 269 ! + ^^^^^^^^^^^^^^^^^^^^^^ 270 dtC_sv(ikl,isl) = dt__SV/max(epsi, & ! dt / (dz X rho C) 271 dzsnSV(ikl,isl) * ro__SV(ikl,isl) *Cn_dSV) ! 272 END DO 273 274 275 ! +--Snow 276 ! + ---- 277 278 DO ikl=1,knonv 279 DO isl=1,min(nsno,isnoSV(ikl)+1) 280 ro__SV(ikl,isl) = & ! 281 ro__SV(ikl ,isl) & ! 282 * max(0,min(isnoSV(ikl)-isl+1,1)) ! 283 284 END DO 285 END DO 286 287 DO ikl=1,knonv 288 DO isl=1,min(nsno,isnoSV(ikl)+1) 289 290 ! +--Combined Heat Conductivity 291 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 292 mu_aux = CdidSV & ! 293 *(ro__SV(ikl,isl) /ro_Wat) ** 1.88 ! 294 mu__dz(ikl,isl) = & ! 295 2. *mu_aux*mu_sno(ikl) & ! Combined Heat 296 /max(epsi,dzsnSV(ikl,isl )*mu_sno(ikl) & ! Conductivity 297 +dzsnSV(ikl,isl-1)*mu_aux ) ! For upper Layer 298 mu_sno(ikl) = mu_aux ! 299 300 ! +--Inverted Heat Capacity 301 ! + ^^^^^^^^^^^^^^^^^^^^^^ 302 dtC_sv(ikl,isl) = dt__SV/max(eps__3, & ! dt / (dz X rho C) 303 dzsnSV(ikl,isl) * ro__SV(ikl,isl) *Cn_dSV) ! 304 END DO 305 END DO 306 307 308 ! +--Uppermost Effective Layer: NO conduction 309 ! + ---------------------------------------- 310 311 DO ikl=1,knonv 312 mu__dz(ikl,isnoSV(ikl)+1) = 0.0 313 END DO 314 315 316 ! +--Energy Budget (IN) 317 ! + ================== 318 319 ! #e1 DO ikl=1,knonv 320 ! #e1 ETSo_0(ikl) = 0. 321 ! #e1 END DO 322 ! #e1 DO isl= -nsol,nsno 323 ! #e1 DO ikl=1,knonv 324 ! #e1 Exist0 = isl - isnoSV(ikl) 325 ! #e1 Exist0 = 1. - max(zero,min(unun,Exist0)) 326 ! #e1 ETSo_0(ikl) = ETSo_0(ikl) 327 ! #e1. +(TsisSV(ikl,isl)-TfSnow)*Exist0 328 ! #e1. /dtC_sv(ikl,isl) 329 ! #e1 END DO 330 ! #e1 END DO 331 332 333 ! +--Tridiagonal Elimination: Set Up 334 ! + =============================== 335 336 ! +--Soil/Snow Interior 337 ! + ^^^^^^^^^^^^^^^^^^ 338 DO ikl=1,knonv 339 DO isl=-nsol+1,min(nsno-1,isnoSV(ikl)+1) 340 341 Elem_A = dtC_sv(ikl,isl) *mu__dz(ikl,isl) 342 Elem_C = dtC_sv(ikl,isl) *mu__dz(ikl,isl+1) 343 Diag_A(ikl,isl) = -Elem_A *Implic 344 Diag_C(ikl,isl) = -Elem_C *Implic 345 Diag_B(ikl,isl) = 1.0d+0 -Diag_A(ikl,isl)-Diag_C(ikl,isl) 346 Term_D(ikl,isl) = Explic *(Elem_A *TsisSV(ikl,isl-1) & 347 +Elem_C *TsisSV(ikl,isl+1)) & 348 +(1.0d+0 -Explic *(Elem_A+Elem_C))*TsisSV(ikl,isl) & 349 + dtC_sv(ikl,isl) * sol_SV(ikl) *SoSosv(ikl) & 350 *(sEX_sv(ikl,isl+1) & 351 -sEX_sv(ikl,isl )) 352 END DO 353 END DO 354 355 ! +--Soil lowest Layer 356 ! + ^^^^^^^^^^^^^^^^^^ 357 isl= -nsol 358 DO ikl=1,knonv 359 Elem_A = 0. 360 Elem_C = dtC_sv(ikl,isl) *mu__dz(ikl,isl+1) 361 Diag_A(ikl,isl) = 0. 362 Diag_C(ikl,isl) = -Elem_C *Implic 363 Diag_B(ikl,isl) = 1.0d+0 -Diag_A(ikl,isl)-Diag_C(ikl,isl) 364 Term_D(ikl,isl) = Explic * Elem_C *TsisSV(ikl,isl+1) & 365 +(1.0d+0 -Explic * Elem_C) *TsisSV(ikl,isl) & 366 + dtC_sv(ikl,isl) * sol_SV(ikl) *SoSosv(ikl) & 367 *(sEX_sv(ikl,isl+1) & 368 -sEX_sv(ikl,isl )) 369 END DO 370 371 ! +--Snow highest Layer (dummy!) 372 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ 373 374 ! !EV!isl= min(isnoSV(1)+1,nsno) 375 376 DO ikl=1,knonv 377 ! EV try to calculate isl at the ikl grid point 378 isl= min(isnoSV(ikl)+1,nsno) 379 380 Elem_A = dtC_sv(ikl,isl) *mu__dz(ikl,isl) 381 Elem_C = 0. 382 Diag_A(ikl,isl) = -Elem_A *Implic 383 Diag_C(ikl,isl) = 0. 384 Diag_B(ikl,isl) = 1.0d+0 -Diag_A(ikl,isl) 385 Term_D(ikl,isl) = Explic * Elem_A *TsisSV(ikl,isl-1) & 386 +(1.0d+0 -Explic * Elem_A) *TsisSV(ikl,isl) & 387 + dtC_sv(ikl,isl) * (sol_SV(ikl) *SoSosv(ikl) & 388 *(sEX_sv(ikl,isl+1) & 389 -sEX_sv(ikl,isl ))) 390 END DO 391 392 ! +--Surface: UPwardIR Heat Flux 393 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ 394 DO ikl=1,knonv 395 isl = isnoSV(ikl) 396 dIRsdT(ikl) = Eso_sv(ikl)* StefBo * 4. & ! - d(IR)/d(T) 397 * TsisSV(ikl,isl) & ! 398 * TsisSV(ikl,isl) & ! 399 * TsisSV(ikl,isl) ! 400 IRs__D(ikl) = dIRsdT(ikl)* TsisSV(ikl,isl) * 0.75 ! 401 402 ! +--Surface: Richardson Number: T Derivative 403 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 404 ! #RC dRidTs(ikl) =-gravit * za__SV(ikl) 405 ! #RC. /(TaT_SV(ikl) * VV__SV(ikl) 406 ! #RC. * VV__SV(ikl)) 407 408 ! +--Surface: Turbulent Heat Flux: Factors 409 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 410 f_HSHL(ikl) = rhT_SV(ikl) / rah_sv(ikl) ! to HS, HL 411 f___HL(ikl) = f_HSHL(ikl) * Lx_H2O(ikl) 412 413 ! +--Surface: Sensible Heat Flux: T Derivative 414 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 415 dSdTSV(ikl) = f_HSHL(ikl) * Cp !#- d(HS)/d(T) 416 ! #RC. *(1.0 -(TsisSV(ikl,isl) -TaT_SV(ikl)) !#Richardson 417 ! #RC. * dRidTs(ikl)*dFh_sv(ikl)/rah_sv(ikl)) ! Nb. Correct. 418 HS___D(ikl) = dSdTSV(ikl) * TaT_SV(ikl) ! 419 420 ! +--Surface: Latent Heat Flux: Saturation Specific Humidity 421 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 422 ! den_qs = TsisSV(ikl,isl)- 35.8 ! 423 ! arg_qs = 17.27 *(TsisSV(ikl,isl)-273.16) ! 424 ! . / den_qs ! 425 ! qsatsg(ikl) = .0038 * exp(arg_qs) ! 426 ! sp = (pst_SV(ikl) + ptopSV) * 10. 427 428 ! !sp=ps__SV(ikl) 429 ! ! Etienne: in the formula herebelow sp should be in hPa, not 430 ! ! in Pa so I divide by 100. 431 sp=ps__SV(ikl)/100. 432 psat_ice = 6.1070 * exp(6150. *(1./273.16 - & 433 1./TsisSV(ikl,isl))) 434 435 psat_wat = 6.1078 * exp (5.138*log(273.16 /TsisSV(ikl,isl))) & 436 * exp (6827.*(1. /273.16-1./TsisSV(ikl,isl))) 437 438 if(TsisSV(ikl,isl)<=273.16) then 439 qsatsg(ikl) = 0.622 * psat_ice / (sp - 0.378 * psat_ice) 440 else 441 qsatsg(ikl) = 0.622 * psat_wat / (sp - 0.378 * psat_wat) 442 endif 443 QsT_SV(ikl)=qsatsg(ikl) 444 445 ! dqs_dT(ikl) = qsatsg(ikl)* 4099.2 /(den_qs *den_qs)! 446 fac_dt(ikl) = f_HSHL(ikl)/(ro_Wat * dz_dSV(0)) ! 447 END DO 448 449 450 451 ! +--Surface: Latent Heat Flux: Surface Relative Humidity 452 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 453 xgpsrf = 1.05 ! 454 agpsrf = dt__SV*( 1.0-xgpsrf ) & ! 455 /( 1.0-xgpsrf**nt_srf) ! 456 dt_srf = agpsrf ! 457 dt_ver = 0. 458 157 459 DO ikl=1,knonv 158 159 mu_sno(ikl)=0. 160 mu__dz(ikl,:)=0. 161 dtC_sv(ikl,:)=0. 162 IRs__D(ikl)=0. 163 dIRsdT(ikl)=0. 164 f_HSHL(ikl)=0. 165 dRidTs(ikl)=0. 166 HS___D(ikl)=0. 167 f___HL(ikl)=0. 168 HL___D(ikl)=0. 169 TSurf0(ikl)=0. 170 qsatsg(ikl)=0. 171 dqs_dT(ikl)=0. 172 Psi(ikl)=0. 173 RHuSol(ikl)=0. 174 Diag_A(ikl,:)=0. 175 Diag_B(ikl,:)=0. 176 Diag_C(ikl,:)=0. 177 Term_D(ikl,:)=0. 178 Aux__P(ikl,:)=0. 179 Aux__Q(ikl,:)=0. 180 etaBAK(ikl)=0. 181 etaNEW(ikl)=0. 182 etEuBk(ikl)=0. 183 fac_dt(ikl)=0. 184 faceta(ikl)=0. 185 PsiArg(ikl)=0. 186 SHuSol(ikl)=0. 187 460 isl = isnoSV(ikl) 461 ist = max(0,isotSV(ikl)-100*isnoSV(ikl))! 0 if H2O 462 ist__s = min(1,ist) 463 etaBAK(ikl) = max(epsi,eta_SV(ikl ,isl)) ! 464 etaNEW(ikl) = etaBAK(ikl) ! 465 etEuBk(ikl) = etaNEW(ikl) ! 188 466 END DO 189 467 190 191 192 C +--Heat Conduction Coefficient (zero in the Layers over the highest one) 193 C + =========================== 194 C + ---------------- isl eta_SV, rho C (isl) 195 C + 196 C +--Soil ++++++++++++++++ etaMid, mu (isl) 197 C + ---- 198 C + ---------------- isl-1 eta_SV, rho C (isl-1) 199 isl=-nsol 468 if(ist__s==1) then ! to reduce computer time 469 ! ! 470 DO it_srf=1,nt_srf ! 471 dt_ver = dt_ver +dt_srf ! 472 DO ikl=1,knonv ! 473 faceta(ikl) = fac_dt(ikl)*dt_srf ! 474 ! #VX faceta(ikl) = faceta(ikl) ! 475 ! #VX. /(1.+faceta(ikl)*dQa_SV(ikl)) ! Limitation 476 ! ! by Atm.Conten 477 ! #??. *max(0,sign(1.,qsatsg(ikl)-QaT_SV(ikl)))) ! NO Limitation 478 ! ! of Downw.Flux 479 END DO ! 480 DO itEuBk=1,2 ! 200 481 DO ikl=1,knonv 201 202 mu__dz(ikl,isl) = 0. 203 204 dtC_sv(ikl,isl) = dtz_SV2(isl) * dt__SV ! dt / (dz X rho C) 205 . /((rocsSV(isotSV(ikl)) ! [s / (m.J/m3/K)] 206 . +rcwdSV*eta_SV(ikl,isl)) ! 207 . *LSdzsv(ikl) ) ! 208 END DO 209 DO isl=-nsol+1,0 210 DO ikl=1,knonv 211 ist = isotSV(ikl) ! Soil Type 212 ist__s = min(ist, 1) ! 1 => Soil 213 ist__w = 1 - ist__s ! 1 => Water Body 214 215 etaMid = 0.5*(dz_dSV(isl-1)*eta_SV(ikl,isl-1) ! eta at layers 216 . +dz_dSV(isl) *eta_SV(ikl,isl) ) ! interface 217 . /dzmiSV(isl) ! LSdzsv implicit ! 218 etaMid = max(etaMid,epsi) 219 psiMid = psidSV(ist) 220 . *(etadSV(ist)/etaMid)**bCHdSV(ist) 221 mu_eta = 3.82 *(psiMid)**mu_exp ! Soil Thermal 222 mu_eta = min(max(mu_eta, mu_min), mu_max) ! Conductivity 223 C + ! DR97 eq.3.31 224 mu_eta = ist__s *mu_eta +ist__w * vK_dSV ! Water Bodies 225 C + ! Correction 226 mu__dz(ikl,isl) = mu_eta/(dzmiSV(isl) ! 227 . *LSdzsv(ikl)) ! 228 229 dtC_sv(ikl,isl) = dtz_SV2(isl)* dt__SV ! dt / (dz X rho C) 230 . /((rocsSV(isotSV(ikl)) ! 231 . +rcwdSV*eta_SV(ikl,isl)) ! 232 . *LSdzsv(ikl) ) ! 233 END DO 234 END DO 235 236 237 C +--Soil/Snow Interface 238 C + ------------------- 239 240 C +--Soil Contribution 241 C + ^^^^^^^^^^^^^^^^^ 242 isl=1 243 DO ikl=1,knonv 244 ist = isotSV(ikl) ! Soil Type 245 ist__s = min(ist, 1) ! 1 => Soil 246 ist__w = 1 - ist__s ! 1 => Water Body 247 psiMid = psidSV(ist) ! Snow => Saturation 248 mu_eta = 3.82 *(psiMid)**mu_exp ! Soil Thermal 249 mu_eta = min(max(mu_eta, mu_min), mu_max) ! Conductivity 250 C + ! DR97 eq.3.31 251 mu_eta = ist__s *mu_eta +ist__w * vK_dSV ! Water Bodies 252 253 C +--Snow Contribution 254 C + ^^^^^^^^^^^^^^^^^ 255 mu_sno(ikl) = CdidSV ! 256 . *(ro__SV(ikl,isl) /ro_Wat) ** 1.88 ! 257 mu_sno(ikl) = max(epsi,mu_sno(ikl)) ! 258 C +... mu_sno : Snow Heat Conductivity Coefficient [Wm/K] 259 C + (Yen 1981, CRREL Rep., 81-10) 260 261 C +--Combined Heat Conductivity 262 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 263 mu__dz(ikl,isl) = 2./(dzsnSV(ikl,isl ) ! Combined Heat 264 . /mu_sno(ikl) ! Conductivity 265 . +LSdzsv(ikl) ! 266 . *dz_dSV( isl-1)/mu_eta) ! Coefficient 267 268 C +--Inverted Heat Capacity 269 C + ^^^^^^^^^^^^^^^^^^^^^^ 270 dtC_sv(ikl,isl) = dt__SV/max(epsi, ! dt / (dz X rho C) 271 . dzsnSV(ikl,isl) * ro__SV(ikl,isl) *Cn_dSV) ! 272 END DO 273 274 275 C +--Snow 276 C + ---- 277 278 DO ikl=1,knonv 279 DO isl=1,min(nsno,isnoSV(ikl)+1) 280 ro__SV(ikl,isl) = ! 281 . ro__SV(ikl ,isl) ! 282 . * max(0,min(isnoSV(ikl)-isl+1,1)) ! 283 284 END DO 285 END DO 286 287 DO ikl=1,knonv 288 DO isl=1,min(nsno,isnoSV(ikl)+1) 289 290 C +--Combined Heat Conductivity 291 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 292 mu_aux = CdidSV ! 293 . *(ro__SV(ikl,isl) /ro_Wat) ** 1.88 ! 294 mu__dz(ikl,isl) = ! 295 . 2. *mu_aux*mu_sno(ikl) ! Combined Heat 296 . /max(epsi,dzsnSV(ikl,isl )*mu_sno(ikl) ! Conductivity 297 . +dzsnSV(ikl,isl-1)*mu_aux ) ! For upper Layer 298 mu_sno(ikl) = mu_aux ! 299 300 C +--Inverted Heat Capacity 301 C + ^^^^^^^^^^^^^^^^^^^^^^ 302 dtC_sv(ikl,isl) = dt__SV/max(eps__3, ! dt / (dz X rho C) 303 . dzsnSV(ikl,isl) * ro__SV(ikl,isl) *Cn_dSV) ! 304 END DO 305 END DO 306 307 308 C +--Uppermost Effective Layer: NO conduction 309 C + ---------------------------------------- 310 311 DO ikl=1,knonv 312 mu__dz(ikl,isnoSV(ikl)+1) = 0.0 313 END DO 314 315 316 C +--Energy Budget (IN) 317 C + ================== 318 319 ! #e1 DO ikl=1,knonv 320 ! #e1 ETSo_0(ikl) = 0. 321 ! #e1 END DO 322 ! #e1 DO isl= -nsol,nsno 323 ! #e1 DO ikl=1,knonv 324 ! #e1 Exist0 = isl - isnoSV(ikl) 325 ! #e1 Exist0 = 1. - max(zero,min(unun,Exist0)) 326 ! #e1 ETSo_0(ikl) = ETSo_0(ikl) 327 ! #e1. +(TsisSV(ikl,isl)-TfSnow)*Exist0 328 ! #e1. /dtC_sv(ikl,isl) 329 ! #e1 END DO 330 ! #e1 END DO 331 332 333 C +--Tridiagonal Elimination: Set Up 334 C + =============================== 335 336 C +--Soil/Snow Interior 337 C + ^^^^^^^^^^^^^^^^^^ 338 DO ikl=1,knonv 339 DO isl=-nsol+1,min(nsno-1,isnoSV(ikl)+1) 340 341 Elem_A = dtC_sv(ikl,isl) *mu__dz(ikl,isl) 342 Elem_C = dtC_sv(ikl,isl) *mu__dz(ikl,isl+1) 343 Diag_A(ikl,isl) = -Elem_A *Implic 344 Diag_C(ikl,isl) = -Elem_C *Implic 345 Diag_B(ikl,isl) = 1.0d+0 -Diag_A(ikl,isl)-Diag_C(ikl,isl) 346 Term_D(ikl,isl) = Explic *(Elem_A *TsisSV(ikl,isl-1) 347 . +Elem_C *TsisSV(ikl,isl+1)) 348 . +(1.0d+0 -Explic *(Elem_A+Elem_C))*TsisSV(ikl,isl) 349 . + dtC_sv(ikl,isl) * sol_SV(ikl) *SoSosv(ikl) 350 . *(sEX_sv(ikl,isl+1) 351 . -sEX_sv(ikl,isl )) 352 END DO 353 END DO 354 355 C +--Soil lowest Layer 356 C + ^^^^^^^^^^^^^^^^^^ 357 isl= -nsol 358 DO ikl=1,knonv 359 Elem_A = 0. 360 Elem_C = dtC_sv(ikl,isl) *mu__dz(ikl,isl+1) 361 Diag_A(ikl,isl) = 0. 362 Diag_C(ikl,isl) = -Elem_C *Implic 363 Diag_B(ikl,isl) = 1.0d+0 -Diag_A(ikl,isl)-Diag_C(ikl,isl) 364 Term_D(ikl,isl) = Explic * Elem_C *TsisSV(ikl,isl+1) 365 . +(1.0d+0 -Explic * Elem_C) *TsisSV(ikl,isl) 366 . + dtC_sv(ikl,isl) * sol_SV(ikl) *SoSosv(ikl) 367 . *(sEX_sv(ikl,isl+1) 368 . -sEX_sv(ikl,isl )) 369 END DO 370 371 C +--Snow highest Layer (dummy!) 372 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ 373 374 !EV!isl= min(isnoSV(1)+1,nsno) 375 376 DO ikl=1,knonv 377 ! EV try to calculate isl at the ikl grid point 378 isl= min(isnoSV(ikl)+1,nsno) 379 380 Elem_A = dtC_sv(ikl,isl) *mu__dz(ikl,isl) 381 Elem_C = 0. 382 Diag_A(ikl,isl) = -Elem_A *Implic 383 Diag_C(ikl,isl) = 0. 384 Diag_B(ikl,isl) = 1.0d+0 -Diag_A(ikl,isl) 385 Term_D(ikl,isl) = Explic * Elem_A *TsisSV(ikl,isl-1) 386 . +(1.0d+0 -Explic * Elem_A) *TsisSV(ikl,isl) 387 . + dtC_sv(ikl,isl) * (sol_SV(ikl) *SoSosv(ikl) 388 . *(sEX_sv(ikl,isl+1) 389 . -sEX_sv(ikl,isl ))) 390 END DO 391 392 C +--Surface: UPwardIR Heat Flux 393 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ 394 DO ikl=1,knonv 395 isl = isnoSV(ikl) 396 dIRsdT(ikl) = Eso_sv(ikl)* StefBo * 4. ! - d(IR)/d(T) 397 . * TsisSV(ikl,isl) ! 398 . * TsisSV(ikl,isl) ! 399 . * TsisSV(ikl,isl) ! 400 IRs__D(ikl) = dIRsdT(ikl)* TsisSV(ikl,isl) * 0.75 ! 401 402 C +--Surface: Richardson Number: T Derivative 403 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 404 c #RC dRidTs(ikl) =-gravit * za__SV(ikl) 405 c #RC. /(TaT_SV(ikl) * VV__SV(ikl) 406 c #RC. * VV__SV(ikl)) 407 408 C +--Surface: Turbulent Heat Flux: Factors 409 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 410 f_HSHL(ikl) = rhT_SV(ikl) / rah_sv(ikl) ! to HS, HL 411 f___HL(ikl) = f_HSHL(ikl) * Lx_H2O(ikl) 412 413 C +--Surface: Sensible Heat Flux: T Derivative 414 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 415 dSdTSV(ikl) = f_HSHL(ikl) * Cp !#- d(HS)/d(T) 416 c #RC. *(1.0 -(TsisSV(ikl,isl) -TaT_SV(ikl)) !#Richardson 417 c #RC. * dRidTs(ikl)*dFh_sv(ikl)/rah_sv(ikl)) ! Nb. Correct. 418 HS___D(ikl) = dSdTSV(ikl) * TaT_SV(ikl) ! 419 420 C +--Surface: Latent Heat Flux: Saturation Specific Humidity 421 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 422 c den_qs = TsisSV(ikl,isl)- 35.8 ! 423 c arg_qs = 17.27 *(TsisSV(ikl,isl)-273.16) ! 424 c . / den_qs ! 425 c qsatsg(ikl) = .0038 * exp(arg_qs) ! 426 ! sp = (pst_SV(ikl) + ptopSV) * 10. 427 428 !sp=ps__SV(ikl) 429 ! Etienne: in the formula herebelow sp should be in hPa, not 430 ! in Pa so I divide by 100. 431 sp=ps__SV(ikl)/100. 432 psat_ice = 6.1070 * exp(6150. *(1./273.16 - 433 . 1./TsisSV(ikl,isl))) 434 435 psat_wat = 6.1078 * exp (5.138*log(273.16 /TsisSV(ikl,isl))) 436 . * exp (6827.*(1. /273.16-1./TsisSV(ikl,isl))) 437 438 if(TsisSV(ikl,isl)<=273.16) then 439 qsatsg(ikl) = 0.622 * psat_ice / (sp - 0.378 * psat_ice) 440 else 441 qsatsg(ikl) = 0.622 * psat_wat / (sp - 0.378 * psat_wat) 442 endif 443 QsT_SV(ikl)=qsatsg(ikl) 444 445 c dqs_dT(ikl) = qsatsg(ikl)* 4099.2 /(den_qs *den_qs)! 446 fac_dt(ikl) = f_HSHL(ikl)/(ro_Wat * dz_dSV(0)) ! 447 END DO 448 449 450 451 C +--Surface: Latent Heat Flux: Surface Relative Humidity 452 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 453 xgpsrf = 1.05 ! 454 agpsrf = dt__SV*( 1.0-xgpsrf ) ! 455 . /( 1.0-xgpsrf**nt_srf) ! 456 dt_srf = agpsrf ! 457 dt_ver = 0. 458 459 DO ikl=1,knonv 460 isl = isnoSV(ikl) 461 ist = max(0,isotSV(ikl)-100*isnoSV(ikl))! 0 if H2O 462 ist__s = min(1,ist) 463 etaBAK(ikl) = max(epsi,eta_SV(ikl ,isl)) ! 464 etaNEW(ikl) = etaBAK(ikl) ! 465 etEuBk(ikl) = etaNEW(ikl) ! 466 END DO 467 468 if(ist__s==1) then ! to reduce computer time 469 ! 470 DO it_srf=1,nt_srf ! 471 dt_ver = dt_ver +dt_srf ! 472 DO ikl=1,knonv ! 473 faceta(ikl) = fac_dt(ikl)*dt_srf ! 474 c #VX faceta(ikl) = faceta(ikl) ! 475 c #VX. /(1.+faceta(ikl)*dQa_SV(ikl)) ! Limitation 476 ! by Atm.Conten 477 c #??. *max(0,sign(1.,qsatsg(ikl)-QaT_SV(ikl)))) ! NO Limitation 478 ! of Downw.Flux 479 END DO ! 480 DO itEuBk=1,2 ! 481 DO ikl=1,knonv 482 ist = max(0,isotSV(ikl)-100*isnoSV(ikl)) ! 0 if H2O 483 ! 484 Psi(ikl) = ! 485 . psidSV(ist) ! DR97, Eqn 3.34 486 . *(etadSV(ist) ! 487 . /max(etEuBk(ikl),epsi)) ! 488 . **bCHdSV(ist) ! 489 PsiArg(ikl) = 7.2E-5*Psi(ikl) ! 490 RHuSol(ikl) = exp(-min(0.,PsiArg(ikl))) ! 491 SHuSol(ikl) = qsatsg(ikl) *RHuSol(ikl) ! DR97, Eqn 3.15 492 etEuBk(ikl) = ! 493 . (etaNEW(ikl) + faceta(ikl)*(QaT_SV(ikl) ! 494 . -SHuSol(ikl) ! 495 . *(1. -bCHdSV(ist) ! 496 . *PsiArg(ikl)) )) ! 497 . /(1. + faceta(ikl)* SHuSol(ikl) ! 498 . *bCHdSV(ist) ! 499 . *PsiArg(ikl) ! 500 . /etaNEW(ikl)) ! 501 etEuBk(ikl) = etEuBk(ikl) ! 502 c . /(Ro_Wat*dz_dSV(0)) ! 503 . * dt_srf /(Ro_Wat*dz_dSV(0)) ! 504 cXF 15/05/2017 BUG 505 END DO ! 506 END DO ! 507 DO ikl=1,knonv ! 508 etaNEW(ikl) = max(etEuBk(ikl),epsi) ! 509 END DO ! 510 dt_srf = dt_srf * xgpsrf ! 511 END DO 512 513 514 endif ! 515 516 C +--Surface: Latent Heat Flux: Soil/Water Surface Contributions 517 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 518 DO ikl=1,knonv ! 519 isl = isnoSV(ikl) ! 520 ist = max(0,isotSV(ikl)-100*isnoSV(ikl)) ! 0 if H2O 521 ist__s= min(1,ist) ! 1 if no H2O 522 ist__w= 1-ist__s ! 1 if H2O 523 d__eta = eta_SV(ikl,isl)-etaNEW(ikl) ! 524 ! latent heat flux computation 525 HL___D(ikl)=( ist__s *ro_Wat *dz_dSV(0) ! Soil Contrib. 526 . *(etaNEW(ikl) -etaBAK(ikl)) / dt__SV ! 527 . +ist__w *f_HSHL(ikl) ! H2O Contrib. 528 . *(QaT_SV(ikl) - qsatsg(ikl)) ) ! 529 . * Lx_H2O(ikl) ! common factor 530 531 c #DL RHuSol(ikl) =(QaT_SV(ikl) ! 532 c #DL. -HL___D(ikl) / f___HL(ikl)) ! 533 c #DL. / qsatsg(ikl) ! 534 535 C +--Surface: Latent Heat Flux: T Derivative 536 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 537 dLdTSV(ikl) = 0. 538 c #DL dLdTSV(ikl) = f___HL(ikl) * RHuSol(ikl) *dqs_dT(ikl) ! - d(HL)/d(T) 539 c #DL HL___D(ikl) = HL___D(ikl) ! 540 c #DL. +dLdTSV(ikl) * TsisSV(ikl,isl) ! 541 END DO ! 542 543 C +--Surface: Tridiagonal Matrix Set Up 544 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 545 DO ikl=1,knonv 546 isl = isnoSV(ikl) 547 TSurf0(ikl) = TsisSV(ikl,isl) 548 549 Elem_A = dtC_sv(ikl,isl)*mu__dz(ikl,isl) 550 Elem_C = 0. 551 Diag_A(ikl,isl) = -Elem_A *Implic 552 Diag_C(ikl,isl) = 0. 553 Diag_B(ikl,isl) = 1.0d+0 -Diag_A(ikl,isl) 554 Diag_B(ikl,isl) = Diag_B(ikl,isl) 555 . + dtC_sv(ikl,isl) * (dIRsdT(ikl) ! Upw. Sol IR 556 . +dSdTSV(ikl) ! HS/Surf.Contr. 557 . +dLdTSV(ikl)) ! HL/Surf.Contr. 558 559 Term_D(ikl,isl) = Explic *Elem_A *TsisSV(ikl,isl-1) 560 . +(1.0d+0 -Explic *Elem_A)*TsisSV(ikl,isl) 561 562 563 564 Term_D(ikl,isl) = Term_D(ikl,isl) 565 . + dtC_sv(ikl,isl) * (sol_SV(ikl) *SoSosv(ikl) ! Absorbed 566 . *(sEX_sv(ikl,isl+1) ! Solar 567 . -sEX_sv(ikl,isl ))! 568 . + IRd_SV(ikl)*Eso_sv(ikl) ! Down Atm IR 569 . +IRs__D(ikl) ! Upw. Sol IR 570 . +HS___D(ikl) ! HS/Atmo.Contr. 571 . +HL___D(ikl) )! HL/Atmo.Contr. 572 573 END DO 574 575 576 C +--Tridiagonal Elimination 577 C + ======================= 578 579 C +--Forward Sweep 580 C + ^^^^^^^^^^^^^^ 581 DO ikl= 1,knonv 582 Aux__P(ikl,-nsol) = Diag_B(ikl,-nsol) 583 Aux__Q(ikl,-nsol) =-Diag_C(ikl,-nsol)/Aux__P(ikl,-nsol) 584 END DO 585 586 DO ikl= 1,knonv 587 588 DO isl=-nsol+1,min(nsno,isnoSV(ikl)+1) 589 Aux__P(ikl,isl) = Diag_A(ikl,isl) *Aux__Q(ikl,isl-1) 590 . +Diag_B(ikl,isl) 591 Aux__Q(ikl,isl) =-Diag_C(ikl,isl) /Aux__P(ikl,isl) 592 END DO 593 END DO 594 595 DO ikl= 1,knonv 596 TsisSV(ikl,-nsol) = Term_D(ikl,-nsol)/Aux__P(ikl,-nsol) 597 END DO 598 599 DO ikl= 1,knonv 600 DO isl=-nsol+1,min(nsno,isnoSV(ikl)+1) 601 TsisSV(ikl,isl) =(Term_D(ikl,isl) 602 . -Diag_A(ikl,isl) *TsisSV(ikl,isl-1)) 603 . /Aux__P(ikl,isl) 604 605 606 END DO 607 END DO 608 609 C +--Backward Sweep 610 C + ^^^^^^^^^^^^^^ 611 DO ikl= 1,knonv 612 DO isl=min(nsno-1,isnoSV(ikl)+1),-nsol,-1 613 614 615 TsisSV(ikl,isl) = Aux__Q(ikl,isl) *TsisSV(ikl,isl+1) 616 . +TsisSV(ikl,isl) 617 if(isl==0.and.isnoSV(ikl)==0) then 618 619 TsisSV(ikl,isl) = min(TaT_SV(ikl)+30,TsisSV(ikl,isl)) 620 TsisSV(ikl,isl) = max(TaT_SV(ikl)-30,TsisSV(ikl,isl)) 621 622 623 c #EU TsisSV(ikl,isl) = max(TaT_SV(ikl)-15.,TsisSV(ikl,isl)) 624 625 !XF 18/11/2018 to avoid ST reaching 70�C!! 626 !It is an error compensation but does not work over tundra 627 628 endif 629 630 631 632 END DO 633 634 END DO 635 636 637 638 C +--Temperature Limits (avoids problems in case of no Snow Layers) 639 C + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 640 DO ikl= 1,knonv 641 isl = isnoSV(ikl) 642 643 dTSurf = TsisSV(ikl,isl) - TSurf0(ikl) 644 TsisSV(ikl,isl) = TSurf0(ikl) + sign(1.,dTSurf) ! 180.0 dgC/hr 645 . * min(abs(dTSurf),5.e-2*dt__SV) ! =0.05 dgC/s 646 647 648 649 END DO 650 651 DO ikl= 1,knonv 652 DO isl=min(nsno,isnoSV(ikl)+1),1 ,-1 653 TsisSV(ikl,isl) = max(Ts_Min, TsisSV(ikl,isl)) 654 TsisSV(ikl,isl) = min(Ts_Max, TsisSV(ikl,isl)) 655 END DO 656 657 END DO 658 659 C +--Update Surface Fluxes 660 C + ======================== 661 662 663 664 DO ikl= 1,knonv 665 isl = isnoSV(ikl) 666 IRs_SV(ikl) = IRs__D(ikl) ! 667 . - dIRsdT(ikl) * TsisSV(ikl,isl) ! 668 HSs_sv(ikl) = HS___D(ikl) ! Sensible Heat 669 . - dSdTSV(ikl) * TsisSV(ikl,isl) ! Downward > 0 670 HLs_sv(ikl) = HL___D(ikl) ! Latent Heat 671 . - dLdTSV(ikl) * TsisSV(ikl,isl) ! Downward > 0 672 END DO 673 674 return 675 end 482 ist = max(0,isotSV(ikl)-100*isnoSV(ikl)) ! 0 if H2O 483 ! ! 484 Psi(ikl) = & ! 485 psidSV(ist) & ! DR97, Eqn 3.34 486 *(etadSV(ist) & ! 487 /max(etEuBk(ikl),epsi)) & ! 488 **bCHdSV(ist) ! 489 PsiArg(ikl) = 7.2E-5*Psi(ikl) ! 490 RHuSol(ikl) = exp(-min(0.,PsiArg(ikl))) ! 491 SHuSol(ikl) = qsatsg(ikl) *RHuSol(ikl) ! DR97, Eqn 3.15 492 etEuBk(ikl) = & ! 493 (etaNEW(ikl) + faceta(ikl)*(QaT_SV(ikl) & ! 494 -SHuSol(ikl) & ! 495 *(1. -bCHdSV(ist) & ! 496 *PsiArg(ikl)) )) & ! 497 /(1. + faceta(ikl)* SHuSol(ikl) & ! 498 *bCHdSV(ist) & ! 499 *PsiArg(ikl) & ! 500 /etaNEW(ikl)) ! 501 etEuBk(ikl) = etEuBk(ikl) & ! 502 ! . /(Ro_Wat*dz_dSV(0)) ! 503 * dt_srf /(Ro_Wat*dz_dSV(0)) ! 504 !XF 15/05/2017 BUG 505 END DO ! 506 END DO ! 507 DO ikl=1,knonv ! 508 etaNEW(ikl) = max(etEuBk(ikl),epsi) ! 509 END DO ! 510 dt_srf = dt_srf * xgpsrf ! 511 END DO 512 513 514 endif ! 515 516 ! +--Surface: Latent Heat Flux: Soil/Water Surface Contributions 517 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 518 DO ikl=1,knonv ! 519 isl = isnoSV(ikl) ! 520 ist = max(0,isotSV(ikl)-100*isnoSV(ikl)) ! 0 if H2O 521 ist__s= min(1,ist) ! 1 if no H2O 522 ist__w= 1-ist__s ! 1 if H2O 523 d__eta = eta_SV(ikl,isl)-etaNEW(ikl) ! 524 ! ! latent heat flux computation 525 HL___D(ikl)=( ist__s *ro_Wat *dz_dSV(0) & ! Soil Contrib. 526 *(etaNEW(ikl) -etaBAK(ikl)) / dt__SV & ! 527 +ist__w *f_HSHL(ikl) & ! H2O Contrib. 528 *(QaT_SV(ikl) - qsatsg(ikl)) ) & ! 529 * Lx_H2O(ikl) ! common factor 530 531 ! #DL RHuSol(ikl) =(QaT_SV(ikl) ! 532 ! #DL. -HL___D(ikl) / f___HL(ikl)) ! 533 ! #DL. / qsatsg(ikl) ! 534 535 ! +--Surface: Latent Heat Flux: T Derivative 536 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 537 dLdTSV(ikl) = 0. 538 ! #DL dLdTSV(ikl) = f___HL(ikl) * RHuSol(ikl) *dqs_dT(ikl) ! - d(HL)/d(T) 539 ! #DL HL___D(ikl) = HL___D(ikl) ! 540 ! #DL. +dLdTSV(ikl) * TsisSV(ikl,isl) ! 541 END DO ! 542 543 ! +--Surface: Tridiagonal Matrix Set Up 544 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 545 DO ikl=1,knonv 546 isl = isnoSV(ikl) 547 TSurf0(ikl) = TsisSV(ikl,isl) 548 549 Elem_A = dtC_sv(ikl,isl)*mu__dz(ikl,isl) 550 Elem_C = 0. 551 Diag_A(ikl,isl) = -Elem_A *Implic 552 Diag_C(ikl,isl) = 0. 553 Diag_B(ikl,isl) = 1.0d+0 -Diag_A(ikl,isl) 554 Diag_B(ikl,isl) = Diag_B(ikl,isl) & 555 + dtC_sv(ikl,isl) * (dIRsdT(ikl) & ! Upw. Sol IR 556 +dSdTSV(ikl) & ! HS/Surf.Contr. 557 +dLdTSV(ikl)) ! HL/Surf.Contr. 558 559 Term_D(ikl,isl) = Explic *Elem_A *TsisSV(ikl,isl-1) & 560 +(1.0d+0 -Explic *Elem_A)*TsisSV(ikl,isl) 561 562 563 564 Term_D(ikl,isl) = Term_D(ikl,isl) & 565 + dtC_sv(ikl,isl) * (sol_SV(ikl) *SoSosv(ikl) & ! Absorbed 566 *(sEX_sv(ikl,isl+1) & ! Solar 567 -sEX_sv(ikl,isl )) & ! 568 + IRd_SV(ikl)*Eso_sv(ikl) & ! Down Atm IR 569 +IRs__D(ikl) & ! Upw. Sol IR 570 +HS___D(ikl) & ! HS/Atmo.Contr. 571 +HL___D(ikl) )! HL/Atmo.Contr. 572 573 END DO 574 575 576 ! +--Tridiagonal Elimination 577 ! + ======================= 578 579 ! +--Forward Sweep 580 ! + ^^^^^^^^^^^^^^ 581 DO ikl= 1,knonv 582 Aux__P(ikl,-nsol) = Diag_B(ikl,-nsol) 583 Aux__Q(ikl,-nsol) =-Diag_C(ikl,-nsol)/Aux__P(ikl,-nsol) 584 END DO 585 586 DO ikl= 1,knonv 587 588 DO isl=-nsol+1,min(nsno,isnoSV(ikl)+1) 589 Aux__P(ikl,isl) = Diag_A(ikl,isl) *Aux__Q(ikl,isl-1) & 590 +Diag_B(ikl,isl) 591 Aux__Q(ikl,isl) =-Diag_C(ikl,isl) /Aux__P(ikl,isl) 592 END DO 593 END DO 594 595 DO ikl= 1,knonv 596 TsisSV(ikl,-nsol) = Term_D(ikl,-nsol)/Aux__P(ikl,-nsol) 597 END DO 598 599 DO ikl= 1,knonv 600 DO isl=-nsol+1,min(nsno,isnoSV(ikl)+1) 601 TsisSV(ikl,isl) =(Term_D(ikl,isl) & 602 -Diag_A(ikl,isl) *TsisSV(ikl,isl-1)) & 603 /Aux__P(ikl,isl) 604 605 606 END DO 607 END DO 608 609 ! +--Backward Sweep 610 ! + ^^^^^^^^^^^^^^ 611 DO ikl= 1,knonv 612 DO isl=min(nsno-1,isnoSV(ikl)+1),-nsol,-1 613 614 615 TsisSV(ikl,isl) = Aux__Q(ikl,isl) *TsisSV(ikl,isl+1) & 616 +TsisSV(ikl,isl) 617 if(isl==0.and.isnoSV(ikl)==0) then 618 619 TsisSV(ikl,isl) = min(TaT_SV(ikl)+30,TsisSV(ikl,isl)) 620 TsisSV(ikl,isl) = max(TaT_SV(ikl)-30,TsisSV(ikl,isl)) 621 622 623 ! #EU TsisSV(ikl,isl) = max(TaT_SV(ikl)-15.,TsisSV(ikl,isl)) 624 625 ! !XF 18/11/2018 to avoid ST reaching 70�C!! 626 ! !It is an error compensation but does not work over tundra 627 628 endif 629 630 631 632 END DO 633 634 END DO 635 636 637 638 ! +--Temperature Limits (avoids problems in case of no Snow Layers) 639 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 640 DO ikl= 1,knonv 641 isl = isnoSV(ikl) 642 643 dTSurf = TsisSV(ikl,isl) - TSurf0(ikl) 644 TsisSV(ikl,isl) = TSurf0(ikl) + sign(1.,dTSurf) & ! 180.0 dgC/hr 645 * min(abs(dTSurf),5.e-2*dt__SV) ! =0.05 dgC/s 646 647 648 649 END DO 650 651 DO ikl= 1,knonv 652 DO isl=min(nsno,isnoSV(ikl)+1),1 ,-1 653 TsisSV(ikl,isl) = max(Ts_Min, TsisSV(ikl,isl)) 654 TsisSV(ikl,isl) = min(Ts_Max, TsisSV(ikl,isl)) 655 END DO 656 657 END DO 658 659 ! +--Update Surface Fluxes 660 ! + ======================== 661 662 663 664 DO ikl= 1,knonv 665 isl = isnoSV(ikl) 666 IRs_SV(ikl) = IRs__D(ikl) & ! 667 - dIRsdT(ikl) * TsisSV(ikl,isl) ! 668 HSs_sv(ikl) = HS___D(ikl) & ! Sensible Heat 669 - dSdTSV(ikl) * TsisSV(ikl,isl) ! Downward > 0 670 HLs_sv(ikl) = HL___D(ikl) & ! Latent Heat 671 - dLdTSV(ikl) * TsisSV(ikl,isl) ! Downward > 0 672 END DO 673 674 return 675 end subroutine sisvat_tso -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_weq.f90
r5245 r5246 1 2 3 subroutine SISVAT_wEq( labWEq ,istart)4 5 C +------------------------------------------------------------------------+6 C | MAR SISVAT_wEq 22-09-2001 MAR |7 C | SubRoutine SISVAT_wEq computes the Snow/Ice Water Equivalent |8 C | |9 C | |10 C | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |11 C | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |12 C | FILE | CONTENT |13 C | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |14 C | # SISVAT_wEq.ve | #ve: OUTPUT/Verification: Snow/Ice Water Eqv. |15 C | | unit 45, SubRoutine SISVAT_wEq **ONLY** |16 C +------------------------------------------------------------------------+17 18 19 20 21 C +--Global Variables22 C + ================23 1 24 use VARphy25 use VAR_SV26 use VARxSV27 28 IMPLICIT NONE29 2 30 31 32 character*6 labWEq 33 integer istart 34 35 logical logWEq 36 common/SISVAT_wEq_L/logWEq 37 38 39 C +--Local Variables 40 C + ================ 41 42 integer ikl ,isn 43 real SnoWEQ,IceWEQ 44 45 46 C +--Switch Initialization 47 C + ===================== 48 49 IF (.NOT.logWEq) THEN 50 logWEq = .true. 51 open(unit=45,status='unknown',file='SISVAT_wEq.ve') 52 rewind 45 53 END IF 54 55 56 C +--Snow Water Equivalent 57 C + ===================== 58 59 ikl = 1 60 IF (isnoSV(ikl).gt.iiceSV(ikl)) THEN 61 62 SnoWEQ = 0. 63 DO isn = iiceSV(ikl)+1 ,isnoSV(ikl) 64 SnoWEQ = SnoWEQ + ro__SV(ikl,isn) * dzsnSV(ikl,isn) 65 END DO 66 67 END IF 68 69 70 C +--Ice Water Equivalent 71 C + ===================== 72 73 IF (iiceSV(1).gt.0) THEN 74 75 IceWEQ = 0. 76 DO isn = 1 ,iiceSV(ikl) 77 IceWEQ = IceWEQ + ro__SV(ikl,isn) * dzsnSV(ikl,isn) 78 END DO 79 80 END IF 81 82 83 C +--OUTPUT 84 C + ====== 85 86 ! IF (istart.eq.1) THEN 87 ! write(45,45)dahost,i___SV(lwriSV(1)),j___SV(lwriSV(1)), 88 ! . n___SV(lwriSV(1)) 89 ! 45 format(a18,10('-'),'Pt.',3i4,60('-')) 90 ! END IF 91 92 ! write(45,450) labWEq,IceWEQ,iiceSV(ikl),SnoWEQ 93 ! . ,IceWEQ+SnoWEQ,isnoSV(ikl) 94 ! . ,drr_SV(ikl)*dt__SV 95 ! . ,dsn_SV(ikl)*dt__SV 96 ! . ,BufsSV(ikl) 97 ! 450 format(a6,3x,' I+S =',f11.4,'(',i2,') +',f11.4,' =', 98 ! . f11.4,'(',i2,')', 99 ! . ' drr =', f7.4, 100 ! . ' dsn =', f7.4, 101 ! . ' Buf =', f7.4) 102 103 return 104 end 3 subroutine SISVAT_wEq( labWEq ,istart) 4 5 ! +------------------------------------------------------------------------+ 6 ! | MAR SISVAT_wEq 22-09-2001 MAR | 7 ! | SubRoutine SISVAT_wEq computes the Snow/Ice Water Equivalent | 8 ! | | 9 ! | | 10 ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) | 11 ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ | 12 ! | FILE | CONTENT | 13 ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ | 14 ! | # SISVAT_wEq.ve | #ve: OUTPUT/Verification: Snow/Ice Water Eqv. | 15 ! | | unit 45, SubRoutine SISVAT_wEq **ONLY** | 16 ! +------------------------------------------------------------------------+ 17 18 19 20 21 ! +--Global Variables 22 ! + ================ 23 24 use VARphy 25 use VAR_SV 26 use VARxSV 27 28 IMPLICIT NONE 29 30 31 32 character(len=6) :: labWEq 33 integer :: istart 34 35 logical :: logWEq 36 common/SISVAT_wEq_L/logWEq 37 38 39 ! +--Local Variables 40 ! + ================ 41 42 integer :: ikl ,isn 43 real :: SnoWEQ,IceWEQ 44 45 46 ! +--Switch Initialization 47 ! + ===================== 48 49 IF (.NOT.logWEq) THEN 50 logWEq = .true. 51 open(unit=45,status='unknown',file='SISVAT_wEq.ve') 52 rewind 45 53 END IF 54 55 56 ! +--Snow Water Equivalent 57 ! + ===================== 58 59 ikl = 1 60 IF (isnoSV(ikl).gt.iiceSV(ikl)) THEN 61 62 SnoWEQ = 0. 63 DO isn = iiceSV(ikl)+1 ,isnoSV(ikl) 64 SnoWEQ = SnoWEQ + ro__SV(ikl,isn) * dzsnSV(ikl,isn) 65 END DO 66 67 END IF 68 69 70 ! +--Ice Water Equivalent 71 ! + ===================== 72 73 IF (iiceSV(1).gt.0) THEN 74 75 IceWEQ = 0. 76 DO isn = 1 ,iiceSV(ikl) 77 IceWEQ = IceWEQ + ro__SV(ikl,isn) * dzsnSV(ikl,isn) 78 END DO 79 80 END IF 81 82 83 ! +--OUTPUT 84 ! + ====== 85 86 !! IF (istart.eq.1) THEN 87 !! write(45,45)dahost,i___SV(lwriSV(1)),j___SV(lwriSV(1)), 88 !! . n___SV(lwriSV(1)) 89 !! 45 format(a18,10('-'),'Pt.',3i4,60('-')) 90 !! END IF 91 92 !! write(45,450) labWEq,IceWEQ,iiceSV(ikl),SnoWEQ 93 !! . ,IceWEQ+SnoWEQ,isnoSV(ikl) 94 !! . ,drr_SV(ikl)*dt__SV 95 !! . ,dsn_SV(ikl)*dt__SV 96 !! . ,BufsSV(ikl) 97 !! 450 format(a6,3x,' I+S =',f11.4,'(',i2,') +',f11.4,' =', 98 !! . f11.4,'(',i2,')', 99 !! . ' drr =', f7.4, 100 !! . ' dsn =', f7.4, 101 !! . ' Buf =', f7.4) 102 103 return 104 end subroutine sisvat_weq -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_zag.f90
r5245 r5246 1 2 3 subroutine SISVAT_zAg 4 . (isagra,isagrb,WEagra5 . ,dzagra,dzagrb,T_agra,T_agrb6 . ,roagra,roagrb,etagra,etagrb7 . ,G1agra,G1agrb,G2agra,G2agrb8 . ,agagra,agagrb,Agreg19 .)10 11 C+------------------------------------------------------------------------+12 C| MAR SURFACE Sat 30-Apr-2004 MAR |13 C| SubRoutine SISVAT_zAg aggregates two contiguous snow layers |14 C| |15 C+------------------------------------------------------------------------+16 C| |17 C| PARAMETERS: knonv: Total Number of columns = |18 C| ^^^^^^^^^^ = Total Number of continental grid boxes |19 C| X Number of Mosaic Cell per grid box |20 C| |21 C| INPUT: isagrb : 2nd Layer History |22 C| ^^^^^ |23 C| |24 C| INPUT: dzagrb : 2nd Layer Thickness |25 C| ^^^^^ T_agrb : 2nd Layer Temperature |26 C| roagrb : 2nd Layer Density |27 C| etagrb : 2nd Layer Water Content |28 C| G1agrb : 2nd Layer Dendricity/Spher. |29 C| G2agrb : 2nd Layer Sphericity/Size |30 C| agagrb : 2nd Age |31 C| Agreg1 : 1. when Agregation constrained |32 C| |33 C| INPUT / isagra : 1st Layer History |34 C| OUTPUT: |35 C| ^^^^^^ |36 C| |37 C| INPUT / dzagra : 1st Layer Thickness |38 C| OUTPUT: T_agra : 1st Layer Temperature |39 C| ^^^^^^ roagra : 1st Layer Density |40 C| etagra : 1st Layer Water Content |41 C| G1agra : 1st Layer Dendricity/Spher. |42 C| G2agra : 1st Layer Sphericity/Size |43 C| agagra : 1st Age |44 C| |45 C+------------------------------------------------------------------------+46 47 48 49 50 C+--Global Variables51 C+ ================52 53 54 55 56 57 58 59 60 61 62 C+--INPUT63 C+ -----64 65 integerisagrb(knonv) ! 2nd Layer History66 realdzagrb(knonv) ! 2nd Layer Thickness67 realT_agrb(knonv) ! 2nd Layer Temperature68 realroagrb(knonv) ! 2nd Layer Density69 realetagrb(knonv) ! 2nd Layer Water Content70 realG1agrb(knonv) ! 2nd Layer Dendricity/Spher.71 realG2agrb(knonv) ! 2nd Layer Sphericity/Size72 realagagrb(knonv) ! 2nd Layer Age73 74 75 C+--INPUT/OUTPUT76 C+ ------------77 78 integerisagra(knonv) ! 1st Layer History79 realWEagra(knonv) ! 1st Layer Height [mm w.e.]80 realAgreg1(knonv) ! 1. ===> Agregates81 realdzagra(knonv) ! 1st Layer Thickness82 realT_agra(knonv) ! 1st Layer Temperature83 realroagra(knonv) ! 1st Layer Density84 realetagra(knonv) ! 1st Layer Water Content85 realG1agra(knonv) ! 1st Layer Dendricity/Spher.86 realG2agra(knonv) ! 1st Layer Sphericity/Size87 realagagra(knonv) ! 1st Layer Age88 89 90 C+--Internal Variables91 C+ ==================92 93 integerikl94 integernh ! Averaged Snow History95 integernh__OK ! 1=>Conserve Snow History96 realrh !97 realdz ! Thickness98 realdzro_1 ! Thickness X Density, Lay.199 realdzro_2 ! Thickness X Density, Lay.2100 realdzro ! Thickness X Density, Aver.101 realro ! Averaged Density102 realwn ! Averaged Water Content103 realtn ! Averaged Temperature104 realag ! Averaged Snow Age105 realSameOK ! 1. => Same Type of Grains106 realG1same ! Averaged G1, same Grains107 realG2same ! Averaged G2, same Grains108 realtyp__1 ! 1. => Lay1 Type: Dendritic109 realzroNEW ! dz X ro, if fresh Snow110 realG1_NEW ! G1, if fresh Snow111 realG2_NEW ! G2, if fresh Snow112 realzroOLD ! dz X ro, if old Snow113 realG1_OLD ! G1, if old Snow114 realG2_OLD ! G2, if old Snow115 realSizNEW ! Size, if fresh Snow116 realSphNEW ! Spheric.,if fresh Snow117 realSizOLD ! Size, if old Snow118 realSphOLD ! Spheric.,if old Snow119 realSiz_av ! Averaged Grain Size120 realSph_av ! Averaged Grain Spher.121 realDen_av ! Averaged Grain Dendr.122 realDendOK ! 1. => Average is Dendr.123 realG1diff ! Averaged G1, diff. Grains124 realG2diff ! Averaged G2, diff. Grains125 realG1 ! Averaged G1126 realG2 ! Averaged G2127 128 129 130 C+--Mean Properties131 C+ =================132 133 C+-- 1 Densite, Contenu en Eau, Temperature /134 C+ Density, Water Content, Temperature135 C+ ------------------------------------136 137 138 139 140 141 142 ro = dzro143 ./max(epsi,dz)144 wn = (dzro_1*etagra(ikl) + dzro_2*etagrb(ikl))145 ./max(epsi,dzro)146 tn = (dzro_1*T_agra(ikl) + dzro_2*T_agrb(ikl))147 ./max(epsi,dzro)148 ag = (dzro_1*agagra(ikl) + dzro_2*agagrb(ikl))149 ./max(epsi,dzro)150 151 rh = max(zero,sign(unun,zWEcSV(ikl)152 .-0.5*WEagra(ikl)))153 154 155 c#HB. * nh__OK156 c#HB. + (1-nh__OK)* min(isagra(ikl),isagrb(ikl))157 158 159 160 C+-- 2 Nouveaux Types de Grains / new Grain Types161 C+ -------------------------------------------162 163 C+-- 2.1. Meme Type de Neige / same Grain Type164 C+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^165 SameOK = max(zero,166 .sign(unun, G1agra(ikl) *G1agrb(ikl) - eps_21))167 G1same = (dzro_1*G1agra(ikl) + dzro_2*G1agrb(ikl))168 ./max(epsi,dzro)169 G2same = (dzro_1*G2agra(ikl) + dzro_2*G2agrb(ikl))170 ./max(epsi,dzro)171 172 C+-- 2.2. Types differents / differents Types173 C+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^174 175 zroNEW = typ__1 *dzro_1! ro of Dendr.Lay.176 .+ (1.-typ__1) *dzro_2 !177 G1_NEW = typ__1 *G1agra(ikl)! G1 of Dendr.Lay.178 .+ (1.-typ__1) *G1agrb(ikl) !179 G2_NEW = typ__1 *G2agra(ikl)! G2 of Dendr.Lay.180 .+ (1.-typ__1) *G2agrb(ikl) !181 zroOLD = (1.-typ__1) *dzro_1! ro of Spher.Lay.182 .+ typ__1 *dzro_2 !183 G1_OLD = (1.-typ__1) *G1agra(ikl)! G1 of Spher.Lay.184 .+ typ__1 *G1agrb(ikl) !185 G2_OLD = (1.-typ__1) *G2agra(ikl)! G2 of Spher.Lay.186 .+ typ__1 *G2agrb(ikl) !187 SizNEW = -G1_NEW *DDcdSV/G1_dSV! Size Dendr.Lay.188 . +(1.+G1_NEW /G1_dSV)!189 . *(G2_NEW *DScdSV/G1_dSV!190 .+(1.-G2_NEW /G1_dSV)*DFcdSV) !191 192 193 194 Siz_av = (zroNEW*SizNEW+zroOLD*SizOLD)! Averaged Size195 ./max(epsi,dzro) !196 Sph_av = (zroNEW*SphNEW+zroOLD*SphOLD)! Averaged Sphericity197 ./max(epsi,dzro) !198 Den_av = (Siz_av -( Sph_av *DScdSV!199 . +(1.-Sph_av)*DFcdSV))!200 . / (DDcdSV -( Sph_av *DScdSV!201 .+(1.-Sph_av)*DFcdSV)) !202 DendOK = max(zero,!203 . sign(unun, Sph_av *DScdSV! Small Grains Contr.204 . +(1.-Sph_av)*DFcdSV! Faceted Grains Contr.205 .- Siz_av ))!206 C+... REMARQUE: le type moyen (dendritique ou non) depend207 C+ ^^^^^^^^ de la comparaison avec le diametre optique208 C+ d'une neige recente de dendricite nulle209 C+... REMARK: the mean type (dendritic or not) depends210 C+ ^^^^^^ on the comparaison with the optical diameter211 C+ of a recent snow having zero dendricity212 213 G1diff =( -DendOK *Den_av214 .+(1.-DendOK)*Sph_av) *G1_dSV215 G2diff = DendOK *Sph_av *G1_dSV216 .+(1.-DendOK)*Siz_av217 G1 = SameOK *G1same218 .+(1.-SameOK)*G1diff219 G2 = SameOK *G2same220 .+(1.-SameOK)*G2diff221 222 223 C+--Assignation to new Properties224 C+ =============================225 226 227 228 229 230 231 232 233 234 235 236 237 238 end 1 2 3 subroutine SISVAT_zAg & 4 (isagra,isagrb,WEagra & 5 ,dzagra,dzagrb,T_agra,T_agrb & 6 ,roagra,roagrb,etagra,etagrb & 7 ,G1agra,G1agrb,G2agra,G2agrb & 8 ,agagra,agagrb,Agreg1 & 9 ) 10 11 ! +------------------------------------------------------------------------+ 12 ! | MAR SURFACE Sat 30-Apr-2004 MAR | 13 ! | SubRoutine SISVAT_zAg aggregates two contiguous snow layers | 14 ! | | 15 ! +------------------------------------------------------------------------+ 16 ! | | 17 ! | PARAMETERS: knonv: Total Number of columns = | 18 ! | ^^^^^^^^^^ = Total Number of continental grid boxes | 19 ! | X Number of Mosaic Cell per grid box | 20 ! | | 21 ! | INPUT: isagrb : 2nd Layer History | 22 ! | ^^^^^ | 23 ! | | 24 ! | INPUT: dzagrb : 2nd Layer Thickness | 25 ! | ^^^^^ T_agrb : 2nd Layer Temperature | 26 ! | roagrb : 2nd Layer Density | 27 ! | etagrb : 2nd Layer Water Content | 28 ! | G1agrb : 2nd Layer Dendricity/Spher. | 29 ! | G2agrb : 2nd Layer Sphericity/Size | 30 ! | agagrb : 2nd Age | 31 ! | Agreg1 : 1. when Agregation constrained | 32 ! | | 33 ! | INPUT / isagra : 1st Layer History | 34 ! | OUTPUT: | 35 ! | ^^^^^^ | 36 ! | | 37 ! | INPUT / dzagra : 1st Layer Thickness | 38 ! | OUTPUT: T_agra : 1st Layer Temperature | 39 ! | ^^^^^^ roagra : 1st Layer Density | 40 ! | etagra : 1st Layer Water Content | 41 ! | G1agra : 1st Layer Dendricity/Spher. | 42 ! | G2agra : 1st Layer Sphericity/Size | 43 ! | agagra : 1st Age | 44 ! | | 45 ! +------------------------------------------------------------------------+ 46 47 48 49 50 ! +--Global Variables 51 ! + ================ 52 53 use VARphy 54 use VAR_SV 55 use VARdSV 56 use VAR0SV 57 use VARxSV 58 59 IMPLICIT NONE 60 61 62 ! +--INPUT 63 ! + ----- 64 65 integer :: isagrb(knonv) ! 2nd Layer History 66 real :: dzagrb(knonv) ! 2nd Layer Thickness 67 real :: T_agrb(knonv) ! 2nd Layer Temperature 68 real :: roagrb(knonv) ! 2nd Layer Density 69 real :: etagrb(knonv) ! 2nd Layer Water Content 70 real :: G1agrb(knonv) ! 2nd Layer Dendricity/Spher. 71 real :: G2agrb(knonv) ! 2nd Layer Sphericity/Size 72 real :: agagrb(knonv) ! 2nd Layer Age 73 74 75 ! +--INPUT/OUTPUT 76 ! + ------------ 77 78 integer :: isagra(knonv) ! 1st Layer History 79 real :: WEagra(knonv) ! 1st Layer Height [mm w.e.] 80 real :: Agreg1(knonv) ! 1. ===> Agregates 81 real :: dzagra(knonv) ! 1st Layer Thickness 82 real :: T_agra(knonv) ! 1st Layer Temperature 83 real :: roagra(knonv) ! 1st Layer Density 84 real :: etagra(knonv) ! 1st Layer Water Content 85 real :: G1agra(knonv) ! 1st Layer Dendricity/Spher. 86 real :: G2agra(knonv) ! 1st Layer Sphericity/Size 87 real :: agagra(knonv) ! 1st Layer Age 88 89 90 ! +--Internal Variables 91 ! + ================== 92 93 integer :: ikl 94 integer :: nh ! Averaged Snow History 95 integer :: nh__OK ! 1=>Conserve Snow History 96 real :: rh ! 97 real :: dz ! Thickness 98 real :: dzro_1 ! Thickness X Density, Lay.1 99 real :: dzro_2 ! Thickness X Density, Lay.2 100 real :: dzro ! Thickness X Density, Aver. 101 real :: ro ! Averaged Density 102 real :: wn ! Averaged Water Content 103 real :: tn ! Averaged Temperature 104 real :: ag ! Averaged Snow Age 105 real :: SameOK ! 1. => Same Type of Grains 106 real :: G1same ! Averaged G1, same Grains 107 real :: G2same ! Averaged G2, same Grains 108 real :: typ__1 ! 1. => Lay1 Type: Dendritic 109 real :: zroNEW ! dz X ro, if fresh Snow 110 real :: G1_NEW ! G1, if fresh Snow 111 real :: G2_NEW ! G2, if fresh Snow 112 real :: zroOLD ! dz X ro, if old Snow 113 real :: G1_OLD ! G1, if old Snow 114 real :: G2_OLD ! G2, if old Snow 115 real :: SizNEW ! Size, if fresh Snow 116 real :: SphNEW ! Spheric.,if fresh Snow 117 real :: SizOLD ! Size, if old Snow 118 real :: SphOLD ! Spheric.,if old Snow 119 real :: Siz_av ! Averaged Grain Size 120 real :: Sph_av ! Averaged Grain Spher. 121 real :: Den_av ! Averaged Grain Dendr. 122 real :: DendOK ! 1. => Average is Dendr. 123 real :: G1diff ! Averaged G1, diff. Grains 124 real :: G2diff ! Averaged G2, diff. Grains 125 real :: G1 ! Averaged G1 126 real :: G2 ! Averaged G2 127 128 129 130 ! +--Mean Properties 131 ! + ================= 132 133 ! +-- 1 Densite, Contenu en Eau, Temperature / 134 ! + Density, Water Content, Temperature 135 ! + ------------------------------------ 136 137 DO ikl = 1,knonv 138 dz = dzagra(ikl) + dzagrb(ikl) 139 dzro_1 = roagra(ikl) * dzagra(ikl) 140 dzro_2 = roagrb(ikl) * dzagrb(ikl) 141 dzro = dzro_1 + dzro_2 142 ro = dzro & 143 /max(epsi,dz) 144 wn = (dzro_1*etagra(ikl) + dzro_2*etagrb(ikl)) & 145 /max(epsi,dzro) 146 tn = (dzro_1*T_agra(ikl) + dzro_2*T_agrb(ikl)) & 147 /max(epsi,dzro) 148 ag = (dzro_1*agagra(ikl) + dzro_2*agagrb(ikl)) & 149 /max(epsi,dzro) 150 151 rh = max(zero,sign(unun,zWEcSV(ikl) & 152 -0.5*WEagra(ikl))) 153 nh__OK = rh 154 nh = max(isagra(ikl),isagrb(ikl)) 155 ! #HB. * nh__OK 156 ! #HB. + (1-nh__OK)* min(isagra(ikl),isagrb(ikl)) 157 158 159 160 ! +-- 2 Nouveaux Types de Grains / new Grain Types 161 ! + ------------------------------------------- 162 163 ! +-- 2.1. Meme Type de Neige / same Grain Type 164 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 165 SameOK = max(zero, & 166 sign(unun, G1agra(ikl) *G1agrb(ikl) - eps_21)) 167 G1same = (dzro_1*G1agra(ikl) + dzro_2*G1agrb(ikl)) & 168 /max(epsi,dzro) 169 G2same = (dzro_1*G2agra(ikl) + dzro_2*G2agrb(ikl)) & 170 /max(epsi,dzro) 171 172 ! +-- 2.2. Types differents / differents Types 173 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 174 typ__1 = max(zero,sign(unun,epsi-G1agra(ikl))) ! =1.=> Dendritic 175 zroNEW = typ__1 *dzro_1 & ! ro of Dendr.Lay. 176 + (1.-typ__1) *dzro_2 ! 177 G1_NEW = typ__1 *G1agra(ikl) & ! G1 of Dendr.Lay. 178 + (1.-typ__1) *G1agrb(ikl) ! 179 G2_NEW = typ__1 *G2agra(ikl) & ! G2 of Dendr.Lay. 180 + (1.-typ__1) *G2agrb(ikl) ! 181 zroOLD = (1.-typ__1) *dzro_1 & ! ro of Spher.Lay. 182 + typ__1 *dzro_2 ! 183 G1_OLD = (1.-typ__1) *G1agra(ikl) & ! G1 of Spher.Lay. 184 + typ__1 *G1agrb(ikl) ! 185 G2_OLD = (1.-typ__1) *G2agra(ikl) & ! G2 of Spher.Lay. 186 + typ__1 *G2agrb(ikl) ! 187 SizNEW = -G1_NEW *DDcdSV/G1_dSV & ! Size Dendr.Lay. 188 +(1.+G1_NEW /G1_dSV) & ! 189 *(G2_NEW *DScdSV/G1_dSV & ! 190 +(1.-G2_NEW /G1_dSV)*DFcdSV) ! 191 SphNEW = G2_NEW /G1_dSV ! Spher.Dendr.Lay. 192 SizOLD = G2_OLD ! Size Spher.Lay. 193 SphOLD = G1_OLD /G1_dSV ! Spher.Spher.Lay. 194 Siz_av = (zroNEW*SizNEW+zroOLD*SizOLD) & ! Averaged Size 195 /max(epsi,dzro) ! 196 Sph_av = (zroNEW*SphNEW+zroOLD*SphOLD) & ! Averaged Sphericity 197 /max(epsi,dzro) ! 198 Den_av = (Siz_av -( Sph_av *DScdSV & ! 199 +(1.-Sph_av)*DFcdSV)) & ! 200 / (DDcdSV -( Sph_av *DScdSV & ! 201 +(1.-Sph_av)*DFcdSV)) ! 202 DendOK = max(zero, & ! 203 sign(unun, Sph_av *DScdSV & ! Small Grains Contr. 204 +(1.-Sph_av)*DFcdSV & ! Faceted Grains Contr. 205 - Siz_av ))! 206 ! +... REMARQUE: le type moyen (dendritique ou non) depend 207 ! + ^^^^^^^^ de la comparaison avec le diametre optique 208 ! + d'une neige recente de dendricite nulle 209 ! +... REMARK: the mean type (dendritic or not) depends 210 ! + ^^^^^^ on the comparaison with the optical diameter 211 ! + of a recent snow having zero dendricity 212 213 G1diff =( -DendOK *Den_av & 214 +(1.-DendOK)*Sph_av) *G1_dSV 215 G2diff = DendOK *Sph_av *G1_dSV & 216 +(1.-DendOK)*Siz_av 217 G1 = SameOK *G1same & 218 +(1.-SameOK)*G1diff 219 G2 = SameOK *G2same & 220 +(1.-SameOK)*G2diff 221 222 223 ! +--Assignation to new Properties 224 ! + ============================= 225 226 isagra(ikl) = Agreg1(ikl) *nh +(1.-Agreg1(ikl)) *isagra(ikl) 227 dzagra(ikl) = Agreg1(ikl) *dz +(1.-Agreg1(ikl)) *dzagra(ikl) 228 T_agra(ikl) = Agreg1(ikl) *tn +(1.-Agreg1(ikl)) *T_agra(ikl) 229 roagra(ikl) = Agreg1(ikl) *ro +(1.-Agreg1(ikl)) *roagra(ikl) 230 etagra(ikl) = Agreg1(ikl) *wn +(1.-Agreg1(ikl)) *etagra(ikl) 231 G1agra(ikl) = Agreg1(ikl) *G1 +(1.-Agreg1(ikl)) *G1agra(ikl) 232 G2agra(ikl) = Agreg1(ikl) *G2 +(1.-Agreg1(ikl)) *G2agra(ikl) 233 agagra(ikl) = Agreg1(ikl) *ag +(1.-Agreg1(ikl)) *agagra(ikl) 234 235 END DO 236 237 return 238 end subroutine sisvat_zag -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_zcr.f90
r5245 r5246 1 2 3 subroutine SISVAT_zCr4 C +5 C +------------------------------------------------------------------------+6 C | MAR SISVAT_zCr 12-12-2002 MAR |7 C | SubRoutine SISVAT_zCr determines criteria for Layers Agregation |8 C | |9 C +------------------------------------------------------------------------+10 C | |11 C | PARAMETERS: klonv: Total Number of columns = |12 C | ^^^^^^^^^^ = Total Number of continental grid boxes |13 C | X Number of Mosaic Cell per grid box |14 C | |15 C | INPUT / isnoSV = total Nb of Ice/Snow Layers |16 C | OUTPUT: iiceSV = total Nb of Ice Layers |17 C | ^^^^^^ ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer |18 C | istoSV = 0,...,5 : Snow History (see istdSV data) |19 C | |20 C | INPUT / ro__SV : Soil/Snow Volumic Mass [kg/m3] |21 C | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] |22 C | ^^^^^^ G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer |23 C | G2snSV : Sphericity (>0) or Size of Snow Layer |24 C | agsnSV : Snow Age [day] |25 C | |26 C | OUTPUT: LIndsv : Relative Index of a contiguous Layer to agregate |27 C | ^^^^^^ |28 C +------------------------------------------------------------------------+29 C +30 C +31 C +32 C +33 C +--Global Variables34 C + ================35 C36 use VARphy37 use VAR_SV38 use VARdSV39 use VAR0SV40 use VARxSV41 use VARySV42 use VARtSV43 44 IMPLICIT NONE45 1 46 C +47 C +48 C +--Internal Variables49 C + ==================50 C +51 integer ikl ,isn ,is0 ,is152 integer isno_1 ! Switch: ! Snow Layer over Ice53 real Dtyp_0,Dtyp_1 ! Snow Grains Difference Measure54 real DenSph ! 1. when contiguous spheric55 C + ! and dendritic Grains56 real DendOK ! 1. when dendritic Grains57 real dTypMx ! Grain Type Differ.58 real dTypSp ! Sphericity Weight59 real dTypRo ! Density Weight60 real dTypDi ! Grain Diam.Weight61 real dTypHi ! History Weight62 63 64 C +--DATA65 C + ====66 67 data dTypMx / 200.0 / ! Grain Type Weight68 data dTypSp / 0.5 / ! Sphericity Weight69 data dTypRo / 0.5 / ! Density Weight70 data dTypDi / 10.0 / ! Grain Diam.Weight71 data dTypHi / 100.0 / ! History Weight72 73 74 C +--Agregation Criteria75 C + ===================76 C +77 DO ikl=1,knonv78 i_thin(ikl) = min(i_thin(ikl),isnoSV(ikl))79 isn = max(1 ,i_thin(ikl))80 C +81 C +82 C +--Comparison with the downward Layer83 C + ----------------------------------84 C +85 2 86 is0 = max(1, i_thin(ikl)-1 ) ! Downward Layer Index 87 DenSph = max(zero, ! isn/is1 88 . sign(unun, ! Dendricity/Sphericity 89 . epsi-G1snSV(ikl,isn) ! Switch 90 . *G1snSV(ikl,is0))) ! 91 DendOK = max(zero, ! Dendricity Switch 92 . sign(unun, ! 93 . epsi-G1snSV(ikl,isn))) ! 94 C + 95 Dtyp_0 = 96 . DenSph * dTypMx 97 . +(1.-DenSph) 98 . * DendOK *((abs(G1snSV(ikl,isn) ! Dendricity 99 . -G1snSV(ikl,is0)) ! Contribution 100 . +abs(G2snSV(ikl,isn) ! Sphericity 101 . -G2snSV(ikl,is0))) *dTypSp ! Contribution 102 . +abs(ro__SV(ikl,isn) ! Density 103 . -ro__SV(ikl,is0)) *dTypRo) ! Contribution 104 . +(1.-DenSph) ! 105 . *(1.-DendOK)*((abs(G1snSV(ikl,isn) ! Sphericity 106 . -G1snSV(ikl,is0)) ! Contribution 107 . +abs(G2snSV(ikl,isn) ! Size 108 . -G2snSV(ikl,is0))) *dTypDi ! Contribution 109 . +abs(ro__SV(ikl,isn) ! Density 110 . -ro__SV(ikl,is0)) *dTypRo) ! Contribution 111 Dtyp_0 = ! 112 . min(dTypMx, ! 113 . Dtyp_0 ! 114 . +abs(istoSV(ikl,isn) ! History 115 . -istoSV(ikl,is0)) *dTypHi) ! Contribution 116 . + (1 -abs(isn-is0)) * 1.e+6 !"Same Layer"Score 117 . + max(0,1-abs(iiceSV(ikl) !"Ice /Snow 118 . -is0)) * 1.e+6 ! Interface" Score 119 C + 120 C + 121 C +--Comparison with the upward Layer 122 C + ---------------------------------- 123 C + 124 is1 = min( i_thin(ikl)+1, ! Upward Layer Index 125 . max(1, isnoSV(ikl) )) ! 126 DenSph = max(zero, ! isn/is1 127 . sign(unun, ! Dendricity/Sphericity 128 . epsi-G1snSV(ikl,isn) ! Switch 129 . *G1snSV(ikl,is1))) ! 130 DendOK = max(zero, ! Dendricity Switch 131 . sign(unun, ! 132 . epsi-G1snSV(ikl,isn))) ! 133 C + 134 Dtyp_1 = 135 . DenSph * dTypMx 136 . +(1.-DenSph) 137 . * DendOK *((abs(G1snSV(ikl,isn) ! Dendricity 138 . -G1snSV(ikl,is1)) ! Contribution 139 . +abs(G2snSV(ikl,isn) ! Sphericity 140 . -G2snSV(ikl,is1))) *dTypSp ! Contribution 141 . +abs(ro__SV(ikl,isn) ! Density 142 . -ro__SV(ikl,is1)) *dTypRo) ! Contribution 143 . +(1.-DenSph) ! 144 . *(1.-DendOK)*((abs(G1snSV(ikl,isn) ! Sphericity 145 . -G1snSV(ikl,is1)) ! Contribution 146 . +abs(G2snSV(ikl,isn) ! Size 147 . -G2snSV(ikl,is1))) *dTypDi ! Contribution 148 . +abs(ro__SV(ikl,isn) ! Density 149 . -ro__SV(ikl,is1)) *dTypRo) ! Contribution 150 Dtyp_1 = ! 151 . min(dTypMx, ! 152 . Dtyp_1 ! 153 . +abs(istoSV(ikl,isn) ! History 154 . -istoSV(ikl,is1)) *dTypHi) ! Contribution 155 . + (1 -abs(isn-is1)) * 1.e+6 !"Same Layer"Score 156 . + max(0,1-abs(iiceSV(ikl) !"Ice /Snow 157 . -isn)) * 1.e+6 ! Interface" Score 158 C + 159 C + 160 C +--Index of the Layer to agregate 161 C + ============================== 162 C + 163 LIndsv(ikl) = sign(unun,Dtyp_0 164 . -Dtyp_1) 165 isno_1 = (1 -min (abs(isnoSV(ikl) ! Switch = 1 166 . -iiceSV(ikl)-1),1)) ! if isno = iice +1 167 . * (1 -min (abs(isnoSV(ikl) ! Switch = 1 168 . -i_thin(ikl) ),1)) ! if isno = i_ithin 169 LIndsv(ikl) = (1 -isno_1) *LIndsv(ikl) ! Contiguous Layer is 170 . -isno_1 ! downward for top L. 171 i_thin(ikl) = max(1, i_thin(ikl) ) 172 END DO 173 C + 174 return 175 end 3 subroutine SISVAT_zCr 4 ! + 5 ! +------------------------------------------------------------------------+ 6 ! | MAR SISVAT_zCr 12-12-2002 MAR | 7 ! | SubRoutine SISVAT_zCr determines criteria for Layers Agregation | 8 ! | | 9 ! +------------------------------------------------------------------------+ 10 ! | | 11 ! | PARAMETERS: klonv: Total Number of columns = | 12 ! | ^^^^^^^^^^ = Total Number of continental grid boxes | 13 ! | X Number of Mosaic Cell per grid box | 14 ! | | 15 ! | INPUT / isnoSV = total Nb of Ice/Snow Layers | 16 ! | OUTPUT: iiceSV = total Nb of Ice Layers | 17 ! | ^^^^^^ ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer | 18 ! | istoSV = 0,...,5 : Snow History (see istdSV data) | 19 ! | | 20 ! | INPUT / ro__SV : Soil/Snow Volumic Mass [kg/m3] | 21 ! | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] | 22 ! | ^^^^^^ G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer | 23 ! | G2snSV : Sphericity (>0) or Size of Snow Layer | 24 ! | agsnSV : Snow Age [day] | 25 ! | | 26 ! | OUTPUT: LIndsv : Relative Index of a contiguous Layer to agregate | 27 ! | ^^^^^^ | 28 ! +------------------------------------------------------------------------+ 29 ! + 30 ! + 31 ! + 32 ! + 33 ! +--Global Variables 34 ! + ================ 35 ! 36 use VARphy 37 use VAR_SV 38 use VARdSV 39 use VAR0SV 40 use VARxSV 41 use VARySV 42 use VARtSV 43 44 IMPLICIT NONE 45 46 ! + 47 ! + 48 ! +--Internal Variables 49 ! + ================== 50 ! + 51 integer :: ikl ,isn ,is0 ,is1 52 integer :: isno_1 ! Switch: ! Snow Layer over Ice 53 real :: Dtyp_0,Dtyp_1 ! Snow Grains Difference Measure 54 real :: DenSph ! 1. when contiguous spheric 55 ! + ! and dendritic Grains 56 real :: DendOK ! 1. when dendritic Grains 57 real :: dTypMx ! Grain Type Differ. 58 real :: dTypSp ! Sphericity Weight 59 real :: dTypRo ! Density Weight 60 real :: dTypDi ! Grain Diam.Weight 61 real :: dTypHi ! History Weight 62 63 64 ! +--DATA 65 ! + ==== 66 67 data dTypMx / 200.0 / ! Grain Type Weight 68 data dTypSp / 0.5 / ! Sphericity Weight 69 data dTypRo / 0.5 / ! Density Weight 70 data dTypDi / 10.0 / ! Grain Diam.Weight 71 data dTypHi / 100.0 / ! History Weight 72 73 74 ! +--Agregation Criteria 75 ! + =================== 76 ! + 77 DO ikl=1,knonv 78 i_thin(ikl) = min(i_thin(ikl),isnoSV(ikl)) 79 isn = max(1 ,i_thin(ikl)) 80 ! + 81 ! + 82 ! +--Comparison with the downward Layer 83 ! + ---------------------------------- 84 ! + 85 86 is0 = max(1, i_thin(ikl)-1 ) ! Downward Layer Index 87 DenSph = max(zero, & ! isn/is1 88 sign(unun, & ! Dendricity/Sphericity 89 epsi-G1snSV(ikl,isn) & ! Switch 90 *G1snSV(ikl,is0))) ! 91 DendOK = max(zero, & ! Dendricity Switch 92 sign(unun, & ! 93 epsi-G1snSV(ikl,isn))) ! 94 ! + 95 Dtyp_0 = & 96 DenSph * dTypMx & 97 +(1.-DenSph) & 98 * DendOK *((abs(G1snSV(ikl,isn) & ! Dendricity 99 -G1snSV(ikl,is0)) & ! Contribution 100 +abs(G2snSV(ikl,isn) & ! Sphericity 101 -G2snSV(ikl,is0))) *dTypSp & ! Contribution 102 +abs(ro__SV(ikl,isn) & ! Density 103 -ro__SV(ikl,is0)) *dTypRo) & ! Contribution 104 +(1.-DenSph) & ! 105 *(1.-DendOK)*((abs(G1snSV(ikl,isn) & ! Sphericity 106 -G1snSV(ikl,is0)) & ! Contribution 107 +abs(G2snSV(ikl,isn) & ! Size 108 -G2snSV(ikl,is0))) *dTypDi & ! Contribution 109 +abs(ro__SV(ikl,isn) & ! Density 110 -ro__SV(ikl,is0)) *dTypRo) ! Contribution 111 Dtyp_0 = & ! 112 min(dTypMx, & ! 113 Dtyp_0 & ! 114 +abs(istoSV(ikl,isn) & ! History 115 -istoSV(ikl,is0)) *dTypHi) & ! Contribution 116 + (1 -abs(isn-is0)) * 1.e+6 & !"Same Layer"Score 117 + max(0,1-abs(iiceSV(ikl) & !"Ice /Snow 118 -is0)) * 1.e+6 ! Interface" Score 119 ! + 120 ! + 121 ! +--Comparison with the upward Layer 122 ! + ---------------------------------- 123 ! + 124 is1 = min( i_thin(ikl)+1, & ! Upward Layer Index 125 max(1, isnoSV(ikl) )) ! 126 DenSph = max(zero, & ! isn/is1 127 sign(unun, & ! Dendricity/Sphericity 128 epsi-G1snSV(ikl,isn) & ! Switch 129 *G1snSV(ikl,is1))) ! 130 DendOK = max(zero, & ! Dendricity Switch 131 sign(unun, & ! 132 epsi-G1snSV(ikl,isn))) ! 133 ! + 134 Dtyp_1 = & 135 DenSph * dTypMx & 136 +(1.-DenSph) & 137 * DendOK *((abs(G1snSV(ikl,isn) & ! Dendricity 138 -G1snSV(ikl,is1)) & ! Contribution 139 +abs(G2snSV(ikl,isn) & ! Sphericity 140 -G2snSV(ikl,is1))) *dTypSp & ! Contribution 141 +abs(ro__SV(ikl,isn) & ! Density 142 -ro__SV(ikl,is1)) *dTypRo) & ! Contribution 143 +(1.-DenSph) & ! 144 *(1.-DendOK)*((abs(G1snSV(ikl,isn) & ! Sphericity 145 -G1snSV(ikl,is1)) & ! Contribution 146 +abs(G2snSV(ikl,isn) & ! Size 147 -G2snSV(ikl,is1))) *dTypDi & ! Contribution 148 +abs(ro__SV(ikl,isn) & ! Density 149 -ro__SV(ikl,is1)) *dTypRo) ! Contribution 150 Dtyp_1 = & ! 151 min(dTypMx, & ! 152 Dtyp_1 & ! 153 +abs(istoSV(ikl,isn) & ! History 154 -istoSV(ikl,is1)) *dTypHi) & ! Contribution 155 + (1 -abs(isn-is1)) * 1.e+6 & !"Same Layer"Score 156 + max(0,1-abs(iiceSV(ikl) & !"Ice /Snow 157 -isn)) * 1.e+6 ! Interface" Score 158 ! + 159 ! + 160 ! +--Index of the Layer to agregate 161 ! + ============================== 162 ! + 163 LIndsv(ikl) = sign(unun,Dtyp_0 & 164 -Dtyp_1) 165 isno_1 = (1 -min (abs(isnoSV(ikl) & ! Switch = 1 166 -iiceSV(ikl)-1),1)) & ! if isno = iice +1 167 * (1 -min (abs(isnoSV(ikl) & ! Switch = 1 168 -i_thin(ikl) ),1)) ! if isno = i_ithin 169 LIndsv(ikl) = (1 -isno_1) *LIndsv(ikl) & ! Contiguous Layer is 170 -isno_1 ! downward for top L. 171 i_thin(ikl) = max(1, i_thin(ikl) ) 172 END DO 173 ! + 174 return 175 end subroutine sisvat_zcr -
LMDZ6/trunk/libf/phylmd/inlandsis/sisvat_zsn.f90
r5245 r5246 1 2 3 4 5 C+------------------------------------------------------------------------+6 C| MAR SISVAT_zSn 12-07-2019 MAR |7 C| SubRoutine SISVAT_zSn manages the Snow Pack vertical Discretization |8 C| |9 C+------------------------------------------------------------------------+10 C| |11 C| PARAMETERS: knonv: Total Number of columns = |12 C| ^^^^^^^^^^ = Total Number of continental grid boxes |13 C| X Number of Mosaic Cell per grid box |14 C| |15 C| INPUT / NLaysv = New Snow Layer Switch |16 C| OUTPUT: isnoSV = total Nb of Ice/Snow Layers |17 C| ^^^^^^ ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer |18 C| iiceSV = total Nb of Ice Layers |19 C| istoSV = 0,...,5 : Snow History (see istdSV data) |20 C| |21 C| INPUT / TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|22 C| OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] |23 C| ^^^^^^ ro__SV : Soil/Snow Volumic Mass [kg/m3] |24 C| eta_SV : Soil/Snow Water Content [m3/m3] |25 C| dzsnSV : Snow Layer Thickness [m] |26 C| G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer |27 C| G2snSV : Sphericity (>0) or Size of Snow Layer |28 C| agsnSV : Snow Age [day] |29 C| |30 C| METHOD: 1) Agregate the thinest Snow Layer |31 C| ^^^^^^ if a new Snow Layer has been precipitated (NLaysv = 1) |32 C| 2) Divide a too thick Snow Layer except |33 C| if the maximum Number of Layer is reached |34 C| in this case forces NLay_s = 1 |35 C| 3) Agregate the thinest Snow Layer |36 C| in order to divide a too thick Snow Layer |37 C| at next Time Step when NLay_s = 1 |38 C| |39 C+------------------------------------------------------------------------+40 41 42 43 44 C+--Global Variables45 C+ ================46 47 48 49 50 51 52 53 54 55 56 57 58 59 C+--Internal Variables60 C+ ==================61 62 integerikl ,isn ,i !63 64 65 66 67 68 69 integerNLay_s(knonv) ! Split Snow Layer Switch70 integerisagr1(knonv) ! 1st Layer History71 integerisagr2(knonv) ! 2nd Layer History72 integerLstLay ! 0 ====> isnoSV = 173 integerisno_n ! Snow Normal.Profile74 integeriice_n ! Ice Normal.Profile75 integeriiceOK ! Ice Switch76 integericemix ! 0 ====> Agregated Snow+Ice=Snow77 C+ ! 1 Ice78 integerisn1 (knonv) ! 1st layer to stagger79 realstaggr ! stagger Switch80 81 realWEagre(knonv) ! Snow Water Equivalent Thickness82 realdzthin(knonv) ! Thickness of the thinest layer83 realOKthin ! Swich ON a new thinest layer84 realdz_dif ! difference from ideal discret.85 realthickL ! Thick Layer Indicator86 realOK_ICE ! Swich ON uppermost Ice Layer87 88 realAgrege(knonv) ! 1. when Agregation constrained89 realdzepsi ! Min Single Snw Layer Thickness90 realdzxmin ! Min Acceptable Layer Thickness91 realdz_min ! Min Layer Thickness92 realdz_max ! Max Layer Thickness93 realdzagr1(knonv) ! 1st Layer Thickness94 realdzagr2(knonv) ! 2nd Layer Thickness95 realT_agr1(knonv) ! 1st Layer Temperature96 realT_agr2(knonv) ! 2nd Layer Temperature97 realroagr1(knonv) ! 1st Layer Density98 realroagr2(knonv) ! 2nd Layer Density99 realetagr1(knonv) ! 1st Layer Water Content100 realetagr2(knonv) ! 2nd Layer Water Content101 realG1agr1(knonv) ! 1st Layer Dendricity/Spher.102 realG1agr2(knonv) ! 2nd Layer Dendricity/Spher.103 realG2agr1(knonv) ! 1st Layer Sphericity/Size104 realG2agr2(knonv) ! 2nd Layer Sphericity/Size105 realagagr1(knonv) ! 1st Layer Age106 realagagr2(knonv) ! 2nd Layer Age107 108 109 C+--DATA110 C+ ====111 112 113 114 115 c#EU data dz_min / 0.0050/ ! Min Local Layer Thickness < SMn116 117 118 C+ CAUTION: dz_max > dz_min*2 is required ! Otherwise re-agregation is119 C+ ! activated after splitting120 121 122 123 124 125 C+--Constrains Agregation of too thin Layers126 C+ =================================================127 128 C+--Search the thinest non-zero Layer129 C+ ----------------------------------130 131 132 133 134 135 136 137 138 139 cXF140 141 142 143 144 145 146 147 ! #vz dz_ref(isn) = !148 ! #vz. dz_min *((1-iiceOK)*isno_n*isno_n ! Theoretical Profile149 ! #vz. + iiceOK * 2**iice_n) !150 ! #vz. /max(1,isnoSV(ikl)) !151 dz_dif = max(zero,! Actual Profile152 . dz_min!153 . *((1-iiceOK)*isno_n*isno_n! Theoretical Profile154 . + iiceOK *2. **iice_n)!155 .- dzsnSV(ikl, isn) ) ! Actual Profile156 ! #vz dzwdif(isn) = dz_dif !157 OKthin = max(zero,!158 . sign(unun,!159 . dz_dif-dzthin(ikl)))! 1.=> New thinest Lay.160 . * max(0,! 1 => .le. isnoSV161 . min(1,! 1 => isn is in the162 . isnoSV(ikl)-isn +1 ))! Snow Pack163 . * min(unun,!164 !165 !1st additional Condition to accept OKthin166 . max(zero,! combination167 . sign(unun,G1snSV(ikl, isn )! G1 with same168 . *G1snSV(ikl,max(1,isn-1))))! sign => OK169 !170 !2nd additional Condition to accept OKthin171 . + max(zero,! G1>0172 . sign(unun,G1snSV(ikl, isn )))! =>OK173 !174 !3rd additional Condition to accept OKthin175 . + max(zero,! dz too small176 . sign(unun,dzxmin! =>OK177 .-dzsnSV(ikl, isn ))))!178 179 i_thin(ikl) = (1. - OKthin) * i_thin(ikl)! Update thinest Lay.180 .+ OKthin * isn ! Index181 dzthin(ikl) = (1. - OKthin) * dzthin(ikl)!182 .+ OKthin * dz_dif !183 184 185 186 187 188 189 190 OKthin = max(zero,!191 . sign(unun,!192 . dz_min!193 . -dzsnSV(ikl,isn)))!194 . * max(zero,! ON if dz > 0195 . sign(unun,!196 . dzsnSV(ikl,isn)-epsi))!197 . *min(1,max(0,! Multiple Snow Lay.198 . min (1,! Switch = 1199 . isnoSV(ikl)! if isno > iice + 1200 . -iiceSV(ikl)-1))!201 C+ !202 . +int(max(zero,!203 . sign(unun,!204 . dzepsi! Minimum accepted for205 . -dzsnSV(ikl,isn))))! 1 Snow Layer over Ice206 . *int(max(zero,! ON if dz > 0207 . sign(unun,!208 . dzsnSV(ikl,isn)-epsi)))!209 . *(1 -min (abs(isnoSV(ikl)! Switch = 1210 . -iiceSV(ikl)-1),1))! if isno = iice + 1211 C+ !212 . +max(0,! Ice213 . min (1,! Switch214 . iiceSV(ikl)+1-isn)))!215 . *min(unun,!216 . max(zero,! combination217 . sign(unun,G1snSV(ikl, isn )! G1>0 + G1<0218 . *G1snSV(ikl,max(1,isn-1))))! NO219 . + max(zero,!220 . sign(unun,G1snSV(ikl, isn )))!221 . + max(zero,!222 . sign(unun,dzxmin!223 .-dzsnSV(ikl, isn ))))!224 i_thin(ikl) = (1. - OKthin) * i_thin(ikl)! Update thinest Lay.225 .+ OKthin * isn ! Index226 227 228 229 230 231 232 C+ ***************233 234 C+ ***************235 236 237 C+--Assign the 2 Layers to agregate238 C+ -------------------------------239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 isnoSV(ikl) = isnoSV(ikl)! decrement isnoSV261 . -(1-LstLay)* max(zero,! if downmost Layer262 . sign(unun,eps_21! < 1.e-21 m263 .-dzsnSV(ikl,1))) !264 265 Agrege(ikl) = max(zero,!266 . sign(unun,dz_min! No Agregation267 . -dzagr1(ikl) ))! if too thick Layer268 . *LstLay! if a single Layer269 . * min( max(0 ,isnoSV(ikl)+1! if Agregation270 . -i_thin(ikl)! with a Layer271 .-LIndsv(ikl) ),1) ! above the Pack272 273 274 275 276 277 278 279 WEagre(ikl) = WEagre(ikl) + ro__SV(ikl,isn)*dzsnSV(ikl,isn)280 .*min(1,max(0,i_thin(ikl)+1-isn))281 282 283 284 285 C+--Agregates286 C+ ---------287 288 C+ ***************289 call SISVAT_zAg290 . (isagr1,isagr2,WEagre291 . ,dzagr1,dzagr2,T_agr1,T_agr2292 . ,roagr1,roagr2,etagr1,etagr2293 . ,G1agr1,G1agr2,G2agr1,G2agr2294 . ,agagr1,agagr2,Agrege295 .)296 C+ ***************297 298 299 C+--Rearranges the Layers300 C+ ---------------------301 302 C+--New (agregated) Snow layer303 C+ ^^^^^^^^^^^^^^^^^^^^^^^^^^304 305 306 307 308 iiceSV(ikl) = iiceSV(ikl)309 . -max(0,sign(1,iiceSV(ikl) -isn +icemix))310 . *Agrege(ikl)311 .*max(0,sign(1,iiceSV(ikl) -1 ))312 istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn)313 .+ Agrege(ikl) *isagr1(ikl)314 dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn)315 .+ Agrege(ikl) *dzagr1(ikl)316 TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn)317 .+ Agrege(ikl) *T_agr1(ikl)318 ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn)319 .+ Agrege(ikl) *roagr1(ikl)320 eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn)321 .+ Agrege(ikl) *etagr1(ikl)322 G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn)323 .+ Agrege(ikl) *G1agr1(ikl)324 G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn)325 .+ Agrege(ikl) *G2agr1(ikl)326 agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn)327 .+ Agrege(ikl) *agagr1(ikl)328 329 330 C+--Above331 C+ ^^^^^332 333 334 335 336 337 338 istoSV(ikl,i) = (1.-staggr )*istoSV(ikl,i )339 . + staggr*((1.-Agrege(ikl))*istoSV(ikl,i )340 .+ Agrege(ikl) *istoSV(ikl,i+1))341 dzsnSV(ikl,i) = (1.-staggr )*dzsnSV(ikl,i )342 . + staggr*((1.-Agrege(ikl))*dzsnSV(ikl,i )343 .+ Agrege(ikl) *dzsnSV(ikl,i+1))344 TsisSV(ikl,i) = (1.-staggr )*TsisSV(ikl,i )345 . + staggr*((1.-Agrege(ikl))*TsisSV(ikl,i )346 .+ Agrege(ikl) *TsisSV(ikl,i+1))347 ro__SV(ikl,i) = (1.-staggr )*ro__SV(ikl,i )348 . + staggr*((1.-Agrege(ikl))*ro__SV(ikl,i )349 .+ Agrege(ikl) *ro__SV(ikl,i+1))350 eta_SV(ikl,i) = (1.-staggr )*eta_SV(ikl,i )351 . + staggr*((1.-Agrege(ikl))*eta_SV(ikl,i )352 .+ Agrege(ikl) *eta_SV(ikl,i+1))353 G1snSV(ikl,i) = (1.-staggr )*G1snSV(ikl,i )354 . + staggr*((1.-Agrege(ikl))*G1snSV(ikl,i )355 .+ Agrege(ikl) *G1snSV(ikl,i+1))356 G2snSV(ikl,i) = (1.-staggr )*G2snSV(ikl,i )357 . + staggr*((1.-Agrege(ikl))*G2snSV(ikl,i )358 .+ Agrege(ikl) *G2snSV(ikl,i+1))359 agsnSV(ikl,i) = (1.-staggr )*agsnSV(ikl,i )360 . + staggr*((1.-Agrege(ikl))*agsnSV(ikl,i )361 .+ Agrege(ikl) *agsnSV(ikl,i+1))362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 C+--Constrains Splitting of too thick Layers381 C+ =================================================382 383 384 C+--Search the thickest non-zero Layer385 C+ ----------------------------------386 387 388 389 390 391 392 393 394 395 dz_dif =( dzsnSV(ikl,isn)! Actual Profile396 . - dz_max *((1-iiceOK)*isno_n*isno_n! Theoretical Profile397 . + iiceOK *2. **iice_n) )!398 ./max(dzsnSV(ikl,isn),epsi) !399 OKthin = max(zero,!400 . sign(unun,!401 . dz_dif-dzthin(ikl)))! 1.=>New thickest Lay.402 . * max(0,! 1 =>.le. isnoSV403 . min(1,!404 .isnoSV(ikl)-isn +1 )) !405 i_thin(ikl) = (1. - OKthin) * i_thin(ikl)! Update thickest Lay.406 .+ OKthin * isn ! Index407 dzthin(ikl) = (1. - OKthin) * dzthin(ikl)!408 .+ OKthin * dz_dif !409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 ThickL = max(zero,! 1. => a too thick439 . sign(unun,dzthin(ikl)! Layer exists440 . -epsi ))!441 . * max(0,1-max(0 , isnoSV(ikl)! No spliting allowed442 .-nsno+1 )) ! if isno > nsno - 1443 Agrege(ikl) = ThickL! 1. => effective split444 . * max(0,1-max(0 , NLaysv(ikl)!445 . +isnoSV(ikl)!446 .-nsno+1 )) !447 NLay_s(ikl) = ThickL! Agregation448 . * max(0,1-max(0 , NLaysv(ikl)! to allow Splitting449 . +isnoSV(ikl)! at next Time Step450 . -nsno ))!451 .-Agrege(ikl) !452 453 454 455 456 C+--Rearranges the Layers457 C+ ---------------------458 459 460 461 462 staggr = min(1,max(0,isn-i_thin(ikl) -1))463 .* min(1,max(0, isnoSV(ikl)-isn+2))464 istoSV(ikl,isn) = staggr * istoSV(ikl ,isn-1)465 .+ (1. - staggr) * istoSV(ikl ,isn )466 dzsnSV(ikl,isn) = staggr * dzsnSV(ikl ,isn-1)467 .+ (1. - staggr) * dzsnSV(ikl ,isn )468 TsisSV(ikl,isn) = staggr * TsisSV(ikl ,isn-1)469 .+ (1. - staggr) * TsisSV(ikl ,isn )470 ro__SV(ikl,isn) = staggr * ro__SV(ikl ,isn-1)471 .+ (1. - staggr) * ro__SV(ikl ,isn )472 eta_SV(ikl,isn) = staggr * eta_SV(ikl ,isn-1)473 .+ (1. - staggr) * eta_SV(ikl ,isn )474 G1snSV(ikl,isn) = staggr * G1snSV(ikl ,isn-1)475 .+ (1. - staggr) * G1snSV(ikl ,isn )476 G2snSV(ikl,isn) = staggr * G2snSV(ikl ,isn-1)477 .+ (1. - staggr) * G2snSV(ikl ,isn )478 agsnSV(ikl,isn) = staggr * agsnSV(ikl ,isn-1)479 .+ (1. - staggr) * agsnSV(ikl ,isn )480 481 482 483 484 485 486 dzsnSV(ikl,isn) = 0.5*Agrege(ikl) *dzsnSV(ikl,isn)487 .+ (1.-Agrege(ikl))*dzsnSV(ikl,isn)488 489 490 istoSV(ikl,isn) = Agrege(ikl) *istoSV(ikl,isn-1)491 .+ (1.-Agrege(ikl))*istoSV(ikl,isn)492 dzsnSV(ikl,isn) = Agrege(ikl) *dzsnSV(ikl,isn-1)493 .+ (1.-Agrege(ikl))*dzsnSV(ikl,isn)494 TsisSV(ikl,isn) = Agrege(ikl) *TsisSV(ikl,isn-1)495 .+ (1.-Agrege(ikl))*TsisSV(ikl,isn)496 ro__SV(ikl,isn) = Agrege(ikl) *ro__SV(ikl,isn-1)497 .+ (1.-Agrege(ikl))*ro__SV(ikl,isn)498 eta_SV(ikl,isn) = Agrege(ikl) *eta_SV(ikl,isn-1)499 .+ (1.-Agrege(ikl))*eta_SV(ikl,isn)500 G1snSV(ikl,isn) = Agrege(ikl) *G1snSV(ikl,isn-1)501 .+ (1.-Agrege(ikl))*G1snSV(ikl,isn)502 G2snSV(ikl,isn) = Agrege(ikl) *G2snSV(ikl,isn-1)503 .+ (1.-Agrege(ikl))*G2snSV(ikl,isn)504 agsnSV(ikl,isn) = Agrege(ikl) *agsnSV(ikl,isn-1)505 .+ (1.-Agrege(ikl))*agsnSV(ikl,isn)506 507 iiceSV(ikl) = iiceSV(ikl)508 . + Agrege(ikl) *max(0,sign(1,iiceSV(ikl)509 . -isn +icemix))510 . *max(0,sign(1,iiceSV(ikl)511 .-1 ))512 513 514 515 C+--Constrains Agregation in case of too much Layers516 C+ =================================================517 518 C+--Search the thinest non-zero Layer519 C+ -----------------------------------520 521 522 523 524 525 526 527 528 529 530 531 532 533 ! #vz dz_ref(isn) = !534 ! #vz. dz_min *((1-iiceOK)*isno_n*isno_n ! Theoretical Profile535 ! #vz. + iiceOK * 2**iice_n) !536 ! #vz. /max(1,isnoSV(ikl)) !537 dz_dif = dz_min! Actual Profile538 . - dzsnSV(ikl ,isn)!539 . /max(epsi,((1-iiceOK)*isno_n*isno_n! Theoretical Profile540 .+ iiceOK *2. **iice_n)) !541 ! #vz dzwdif(isn) = dz_dif !542 OKthin = max(zero,!543 . sign(unun,!544 . dz_dif - dzthin(ikl)))! 1.=> New thinest Lay.545 . * max(0,! 1 => .le. isnoSV546 . min(1,!547 .isnoSV(ikl)-isn +1 )) !548 i_thin(ikl) = (1. - OKthin) * i_thin(ikl)! Update thinest Lay.549 .+ OKthin * isn ! Index550 dzthin(ikl) = (1. - OKthin) * dzthin(ikl)!551 .+ OKthin * dz_dif !552 553 554 555 556 557 558 559 560 561 C+--Index of the contiguous Layer to agregate562 C+ -----------------------------------------563 564 C+ ***************565 566 C+ ***************567 568 569 C+--Assign the 2 Layers to agregate570 C+ -------------------------------571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 Agrege(ikl) = min(1,593 . max(0,594 . NLaysv(ikl) +isnoSV(ikl)-nsno595 . +NLay_s(ikl) )596 .*LstLay )597 598 C+ minimum uppermost layer thickness to guarantee a correct reproduction of the snow599 C+ atmosphere coupling600 if(dzsnSV(ikl,max(1,isnoSV(ikl)-0))>0.02 .or.! surface layers> 2-5-10601 . dzsnSV(ikl,max(1,isnoSV(ikl)-1))>0.05 .or.! XF 04/07/2019602 . dzsnSV(ikl,max(1,isnoSV(ikl)-2))>0.10 .or.603 .dzsnSV(ikl,max(1,isnoSV(ikl)-3))>0.30 )then604 Agrege(ikl) = min(1,605 . max(0,606 . NLaysv(ikl) +isnoSV(ikl)+1-nsno! nsno-1 layers ma607 . +NLay_s(ikl) )608 .*LstLay )609 610 611 isnoSV(ikl) = isnoSV(ikl)612 . -(1-LstLay)*max(zero,613 . sign(unun, eps_21614 .-dzsnSV(ikl,1) ))615 616 617 618 619 620 621 622 WEagre(ikl) = WEagre(ikl) + ro__SV(ikl,isn)*dzsnSV(ikl,isn)623 .*min(1,max(0,i_thin(ikl)+1-isn))624 625 626 627 C+--Agregates628 C+ ---------629 630 C+ ***************631 call SISVAT_zAg632 . (isagr1,isagr2,WEagre633 . ,dzagr1,dzagr2,T_agr1,T_agr2634 . ,roagr1,roagr2,etagr1,etagr2635 . ,G1agr1,G1agr2,G2agr1,G2agr2636 . ,agagr1,agagr2,Agrege637 .)638 C+ ***************639 640 641 C+--Rearranges the Layers642 C+ ---------------------643 644 C+--New (agregated) Snow layer645 C+ ^^^^^^^^^^^^^^^^^^^^^^^^^^646 647 648 649 650 iiceSV(ikl) = iiceSV(ikl)651 . -max(0,sign(1,iiceSV(ikl) -isn +icemix))652 . *Agrege(ikl)653 .*max(0,sign(1,iiceSV(ikl) -1 ))654 istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn)655 .+ Agrege(ikl) *isagr1(ikl)656 dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn)657 .+ Agrege(ikl) *dzagr1(ikl)658 TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn)659 .+ Agrege(ikl) *T_agr1(ikl)660 ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn)661 .+ Agrege(ikl) *roagr1(ikl)662 eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn)663 .+ Agrege(ikl) *etagr1(ikl)664 G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn)665 .+ Agrege(ikl) *G1agr1(ikl)666 G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn)667 .+ Agrege(ikl) *G2agr1(ikl)668 agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn)669 .+ Agrege(ikl) *agagr1(ikl)670 671 672 C+--Above673 C+ ^^^^^674 675 676 677 678 679 680 istoSV(ikl,i) = (1.-staggr )*istoSV(ikl,i )681 . + staggr*((1.-Agrege(ikl))*istoSV(ikl,i )682 .+ Agrege(ikl) *istoSV(ikl,i+1))683 dzsnSV(ikl,i) = (1.-staggr )*dzsnSV(ikl,i )684 . + staggr*((1.-Agrege(ikl))*dzsnSV(ikl,i )685 .+ Agrege(ikl) *dzsnSV(ikl,i+1))686 TsisSV(ikl,i) = (1.-staggr )*TsisSV(ikl,i )687 . + staggr*((1.-Agrege(ikl))*TsisSV(ikl,i )688 .+ Agrege(ikl) *TsisSV(ikl,i+1))689 ro__SV(ikl,i) = (1.-staggr )*ro__SV(ikl,i )690 . + staggr*((1.-Agrege(ikl))*ro__SV(ikl,i )691 .+ Agrege(ikl) *ro__SV(ikl,i+1))692 eta_SV(ikl,i) = (1.-staggr )*eta_SV(ikl,i )693 . + staggr*((1.-Agrege(ikl))*eta_SV(ikl,i )694 .+ Agrege(ikl) *eta_SV(ikl,i+1))695 G1snSV(ikl,i) = (1.-staggr )*G1snSV(ikl,i )696 . + staggr*((1.-Agrege(ikl))*G1snSV(ikl,i )697 .+ Agrege(ikl) *G1snSV(ikl,i+1))698 G2snSV(ikl,i) = (1.-staggr )*G2snSV(ikl,i )699 . + staggr*((1.-Agrege(ikl))*G2snSV(ikl,i )700 .+ Agrege(ikl) *G2snSV(ikl,i+1))701 agsnSV(ikl,i) = (1.-staggr )*agsnSV(ikl,i )702 . + staggr*((1.-Agrege(ikl))*agsnSV(ikl,i )703 .+ Agrege(ikl) *agsnSV(ikl,i+1))704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 C+--Search new Ice/Snow Interface (option II in MAR)721 C+ ===============================================722 723 IF (ok_zsn_ii) THEN724 725 726 727 728 729 730 731 OK_ICE = max(zero,sign(unun,ro__SV(ikl,isn)-ro_ice+20.))732 .* max(zero,sign(unun,dzsnSV(ikl,isn)-epsi))733 iiceSV(ikl) = (1.-OK_ICE) *iiceSV(ikl)734 .+ OK_ICE *isn735 736 737 738 739 740 741 end 1 2 3 subroutine SISVAT_zSn 4 5 ! +------------------------------------------------------------------------+ 6 ! | MAR SISVAT_zSn 12-07-2019 MAR | 7 ! | SubRoutine SISVAT_zSn manages the Snow Pack vertical Discretization | 8 ! | | 9 ! +------------------------------------------------------------------------+ 10 ! | | 11 ! | PARAMETERS: knonv: Total Number of columns = | 12 ! | ^^^^^^^^^^ = Total Number of continental grid boxes | 13 ! | X Number of Mosaic Cell per grid box | 14 ! | | 15 ! | INPUT / NLaysv = New Snow Layer Switch | 16 ! | OUTPUT: isnoSV = total Nb of Ice/Snow Layers | 17 ! | ^^^^^^ ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer | 18 ! | iiceSV = total Nb of Ice Layers | 19 ! | istoSV = 0,...,5 : Snow History (see istdSV data) | 20 ! | | 21 ! | INPUT / TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)| 22 ! | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] | 23 ! | ^^^^^^ ro__SV : Soil/Snow Volumic Mass [kg/m3] | 24 ! | eta_SV : Soil/Snow Water Content [m3/m3] | 25 ! | dzsnSV : Snow Layer Thickness [m] | 26 ! | G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer | 27 ! | G2snSV : Sphericity (>0) or Size of Snow Layer | 28 ! | agsnSV : Snow Age [day] | 29 ! | | 30 ! | METHOD: 1) Agregate the thinest Snow Layer | 31 ! | ^^^^^^ if a new Snow Layer has been precipitated (NLaysv = 1) | 32 ! | 2) Divide a too thick Snow Layer except | 33 ! | if the maximum Number of Layer is reached | 34 ! | in this case forces NLay_s = 1 | 35 ! | 3) Agregate the thinest Snow Layer | 36 ! | in order to divide a too thick Snow Layer | 37 ! | at next Time Step when NLay_s = 1 | 38 ! | | 39 ! +------------------------------------------------------------------------+ 40 41 42 43 44 ! +--Global Variables 45 ! + ================ 46 47 48 use VARphy 49 use VAR_SV 50 use VARdSV 51 use VAR0SV 52 use VARxSV 53 use VARySV 54 use surface_data, only: ok_zsn_ii 55 56 IMPLICIT NONE 57 58 59 ! +--Internal Variables 60 ! + ================== 61 62 integer :: ikl ,isn ,i ! 63 64 65 66 67 68 69 integer :: NLay_s(knonv) ! Split Snow Layer Switch 70 integer :: isagr1(knonv) ! 1st Layer History 71 integer :: isagr2(knonv) ! 2nd Layer History 72 integer :: LstLay ! 0 ====> isnoSV = 1 73 integer :: isno_n ! Snow Normal.Profile 74 integer :: iice_n ! Ice Normal.Profile 75 integer :: iiceOK ! Ice Switch 76 integer :: icemix ! 0 ====> Agregated Snow+Ice=Snow 77 ! + ! 1 Ice 78 integer :: isn1 (knonv) ! 1st layer to stagger 79 real :: staggr ! stagger Switch 80 81 real :: WEagre(knonv) ! Snow Water Equivalent Thickness 82 real :: dzthin(knonv) ! Thickness of the thinest layer 83 real :: OKthin ! Swich ON a new thinest layer 84 real :: dz_dif ! difference from ideal discret. 85 real :: thickL ! Thick Layer Indicator 86 real :: OK_ICE ! Swich ON uppermost Ice Layer 87 88 real :: Agrege(knonv) ! 1. when Agregation constrained 89 real :: dzepsi ! Min Single Snw Layer Thickness 90 real :: dzxmin ! Min Acceptable Layer Thickness 91 real :: dz_min ! Min Layer Thickness 92 real :: dz_max ! Max Layer Thickness 93 real :: dzagr1(knonv) ! 1st Layer Thickness 94 real :: dzagr2(knonv) ! 2nd Layer Thickness 95 real :: T_agr1(knonv) ! 1st Layer Temperature 96 real :: T_agr2(knonv) ! 2nd Layer Temperature 97 real :: roagr1(knonv) ! 1st Layer Density 98 real :: roagr2(knonv) ! 2nd Layer Density 99 real :: etagr1(knonv) ! 1st Layer Water Content 100 real :: etagr2(knonv) ! 2nd Layer Water Content 101 real :: G1agr1(knonv) ! 1st Layer Dendricity/Spher. 102 real :: G1agr2(knonv) ! 2nd Layer Dendricity/Spher. 103 real :: G2agr1(knonv) ! 1st Layer Sphericity/Size 104 real :: G2agr2(knonv) ! 2nd Layer Sphericity/Size 105 real :: agagr1(knonv) ! 1st Layer Age 106 real :: agagr2(knonv) ! 2nd Layer Age 107 108 109 ! +--DATA 110 ! + ==== 111 112 data icemix / 0 / ! 0 ====> Agregated Snow+Ice=Snow 113 data dzepsi / 0.0020/ ! Min single Layer Thickness 114 data dzxmin / 0.0025/ ! Min accept.Layer Thickness 115 ! #EU data dz_min / 0.0050/ ! Min Local Layer Thickness < SMn 116 data dz_min / 0.0040/ ! Min Local Layer Thickness < SMn 117 data dz_max / 0.0300/ ! Min Gener. Layer Thickness 118 ! + CAUTION: dz_max > dz_min*2 is required ! Otherwise re-agregation is 119 ! + ! activated after splitting 120 121 122 123 124 125 ! +--Constrains Agregation of too thin Layers 126 ! + ================================================= 127 128 ! +--Search the thinest non-zero Layer 129 ! + ---------------------------------- 130 131 DO ikl=1,knonv 132 if(isnoSV(ikl)<=2) dz_min=max(0.0050,dz_min) 133 134 dzepsi=0.0015 135 if(ro__SV(ikl,isnoSV(ikl))>920) dzepsi=0.0020 136 137 dzthin(ikl) = 0. ! Arbitrary unrealistic 138 END DO ! Layer Thickness 139 !XF 140 DO ikl=1,knonv 141 DO isn=1,isnoSV(ikl)-3 ! no agregation of 3 first snowlayers 142 ! ! XF 04/07/2019 143 144 isno_n = isnoSV(ikl)-isn+1 ! Snow Normal.Profile 145 iice_n = iiceSV(ikl)-isn ! Ice Normal.Profile 146 iiceOK = min(1,max(0,iice_n +1)) ! Ice Switch 147 ! #vz dz_ref(isn) = ! 148 ! #vz. dz_min *((1-iiceOK)*isno_n*isno_n ! Theoretical Profile 149 ! #vz. + iiceOK * 2**iice_n) ! 150 ! #vz. /max(1,isnoSV(ikl)) ! 151 dz_dif = max(zero, & ! Actual Profile 152 dz_min & ! 153 *((1-iiceOK)*isno_n*isno_n & ! Theoretical Profile 154 + iiceOK *2. **iice_n) & ! 155 - dzsnSV(ikl, isn) ) ! Actual Profile 156 ! #vz dzwdif(isn) = dz_dif ! 157 OKthin = max(zero, & ! 158 sign(unun, & ! 159 dz_dif-dzthin(ikl))) & ! 1.=> New thinest Lay. 160 * max(0, & ! 1 => .le. isnoSV 161 min(1, & ! 1 => isn is in the 162 isnoSV(ikl)-isn +1 )) & ! Snow Pack 163 * min(unun, & ! 164 ! 165 ! 1st additional Condition to accept OKthin 166 max(zero, & ! combination 167 sign(unun,G1snSV(ikl, isn ) & ! G1 with same 168 *G1snSV(ikl,max(1,isn-1)))) & ! sign => OK 169 ! 170 ! 2nd additional Condition to accept OKthin 171 + max(zero, & ! G1>0 172 sign(unun,G1snSV(ikl, isn ))) & ! =>OK 173 ! 174 ! 3rd additional Condition to accept OKthin 175 + max(zero, & ! dz too small 176 sign(unun,dzxmin & ! =>OK 177 -dzsnSV(ikl, isn ))))! 178 179 i_thin(ikl) = (1. - OKthin) * i_thin(ikl) & ! Update thinest Lay. 180 + OKthin * isn ! Index 181 dzthin(ikl) = (1. - OKthin) * dzthin(ikl) & ! 182 + OKthin * dz_dif ! 183 END DO 184 END DO 185 186 187 188 DO ikl=1,knonv 189 DO isn=1,isnoSV(ikl) 190 OKthin = max(zero, & ! 191 sign(unun, & ! 192 dz_min & ! 193 -dzsnSV(ikl,isn))) & ! 194 * max(zero, & ! ON if dz > 0 195 sign(unun, & ! 196 dzsnSV(ikl,isn)-epsi)) & ! 197 *min(1,max(0, & ! Multiple Snow Lay. 198 min (1, & ! Switch = 1 199 isnoSV(ikl) & ! if isno > iice + 1 200 -iiceSV(ikl)-1)) & ! 201 ! + ! 202 +int(max(zero, & ! 203 sign(unun, & ! 204 dzepsi & ! Minimum accepted for 205 -dzsnSV(ikl,isn)))) & ! 1 Snow Layer over Ice 206 *int(max(zero, & ! ON if dz > 0 207 sign(unun, & ! 208 dzsnSV(ikl,isn)-epsi))) & ! 209 *(1 -min (abs(isnoSV(ikl) & ! Switch = 1 210 -iiceSV(ikl)-1),1)) & ! if isno = iice + 1 211 ! + ! 212 +max(0, & ! Ice 213 min (1, & ! Switch 214 iiceSV(ikl)+1-isn))) & ! 215 *min(unun, & ! 216 max(zero, & ! combination 217 sign(unun,G1snSV(ikl, isn ) & ! G1>0 + G1<0 218 *G1snSV(ikl,max(1,isn-1)))) & ! NO 219 + max(zero, & ! 220 sign(unun,G1snSV(ikl, isn ))) & ! 221 + max(zero, & ! 222 sign(unun,dzxmin & ! 223 -dzsnSV(ikl, isn ))))! 224 i_thin(ikl) = (1. - OKthin) * i_thin(ikl) & ! Update thinest Lay. 225 + OKthin * isn ! Index 226 END DO 227 END DO 228 229 230 231 232 ! + *************** 233 call SISVAT_zCr 234 ! + *************** 235 236 237 ! +--Assign the 2 Layers to agregate 238 ! + ------------------------------- 239 240 DO ikl=1,knonv 241 isn = i_thin(ikl) 242 if(LIndsv(ikl)>0) isn=min(nsno-1,isn) ! cXF 243 isagr1(ikl) = istoSV(ikl,isn) 244 isagr2(ikl) = istoSV(ikl,isn+LIndsv(ikl)) 245 dzagr1(ikl) = dzsnSV(ikl,isn) 246 dzagr2(ikl) = dzsnSV(ikl,isn+LIndsv(ikl)) 247 T_agr1(ikl) = TsisSV(ikl,isn) 248 T_agr2(ikl) = TsisSV(ikl,isn+LIndsv(ikl)) 249 roagr1(ikl) = ro__SV(ikl,isn) 250 roagr2(ikl) = ro__SV(ikl,isn+LIndsv(ikl)) 251 etagr1(ikl) = eta_SV(ikl,isn) 252 etagr2(ikl) = eta_SV(ikl,isn+LIndsv(ikl)) 253 G1agr1(ikl) = G1snSV(ikl,isn) 254 G1agr2(ikl) = G1snSV(ikl,isn+LIndsv(ikl)) 255 G2agr1(ikl) = G2snSV(ikl,isn) 256 G2agr2(ikl) = G2snSV(ikl,isn+LIndsv(ikl)) 257 agagr1(ikl) = agsnSV(ikl,isn) 258 agagr2(ikl) = agsnSV(ikl,isn+LIndsv(ikl)) 259 LstLay = min(1,max( 0,isnoSV(ikl) -1)) ! 0 if single Layer 260 isnoSV(ikl) = isnoSV(ikl) & ! decrement isnoSV 261 -(1-LstLay)* max(zero, & ! if downmost Layer 262 sign(unun,eps_21 & ! < 1.e-21 m 263 -dzsnSV(ikl,1))) ! 264 isnoSV(ikl) = max( 0, isnoSV(ikl) ) ! 265 Agrege(ikl) = max(zero, & ! 266 sign(unun,dz_min & ! No Agregation 267 -dzagr1(ikl) )) & ! if too thick Layer 268 *LstLay & ! if a single Layer 269 * min( max(0 ,isnoSV(ikl)+1 & ! if Agregation 270 -i_thin(ikl) & ! with a Layer 271 -LIndsv(ikl) ),1) ! above the Pack 272 273 WEagre(ikl) = 0. 274 END DO 275 276 277 DO ikl=1,knonv 278 DO isn=1,isnoSV(ikl) 279 WEagre(ikl) = WEagre(ikl) + ro__SV(ikl,isn)*dzsnSV(ikl,isn) & 280 *min(1,max(0,i_thin(ikl)+1-isn)) 281 ENDDO 282 ENDDO 283 284 285 ! +--Agregates 286 ! + --------- 287 288 ! + *************** 289 call SISVAT_zAg & 290 (isagr1,isagr2,WEagre & 291 ,dzagr1,dzagr2,T_agr1,T_agr2 & 292 ,roagr1,roagr2,etagr1,etagr2 & 293 ,G1agr1,G1agr2,G2agr1,G2agr2 & 294 ,agagr1,agagr2,Agrege & 295 ) 296 ! + *************** 297 298 299 ! +--Rearranges the Layers 300 ! + --------------------- 301 302 ! +--New (agregated) Snow layer 303 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 304 DO ikl=1,knonv 305 isn = i_thin(ikl) 306 isn = min(isn,isn+LIndsv(ikl)) 307 isnoSV(ikl) = max(0.,isnoSV(ikl) -Agrege(ikl)) 308 iiceSV(ikl) = iiceSV(ikl) & 309 -max(0,sign(1,iiceSV(ikl) -isn +icemix)) & 310 *Agrege(ikl) & 311 *max(0,sign(1,iiceSV(ikl) -1 )) 312 istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn) & 313 + Agrege(ikl) *isagr1(ikl) 314 dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn) & 315 + Agrege(ikl) *dzagr1(ikl) 316 TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn) & 317 + Agrege(ikl) *T_agr1(ikl) 318 ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn) & 319 + Agrege(ikl) *roagr1(ikl) 320 eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn) & 321 + Agrege(ikl) *etagr1(ikl) 322 G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn) & 323 + Agrege(ikl) *G1agr1(ikl) 324 G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn) & 325 + Agrege(ikl) *G2agr1(ikl) 326 agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn) & 327 + Agrege(ikl) *agagr1(ikl) 328 END DO 329 330 ! +--Above 331 ! + ^^^^^ 332 DO ikl=1,knonv 333 isn1(ikl)=max(i_thin(ikl),i_thin(ikl)+LIndsv(ikl)) 334 END DO 335 DO i= 1,nsno-1 336 DO ikl=1,knonv 337 staggr = min(1,max(0,i +1 -isn1(ikl) )) 338 istoSV(ikl,i) = (1.-staggr )*istoSV(ikl,i ) & 339 + staggr*((1.-Agrege(ikl))*istoSV(ikl,i ) & 340 + Agrege(ikl) *istoSV(ikl,i+1)) 341 dzsnSV(ikl,i) = (1.-staggr )*dzsnSV(ikl,i ) & 342 + staggr*((1.-Agrege(ikl))*dzsnSV(ikl,i ) & 343 + Agrege(ikl) *dzsnSV(ikl,i+1)) 344 TsisSV(ikl,i) = (1.-staggr )*TsisSV(ikl,i ) & 345 + staggr*((1.-Agrege(ikl))*TsisSV(ikl,i ) & 346 + Agrege(ikl) *TsisSV(ikl,i+1)) 347 ro__SV(ikl,i) = (1.-staggr )*ro__SV(ikl,i ) & 348 + staggr*((1.-Agrege(ikl))*ro__SV(ikl,i ) & 349 + Agrege(ikl) *ro__SV(ikl,i+1)) 350 eta_SV(ikl,i) = (1.-staggr )*eta_SV(ikl,i ) & 351 + staggr*((1.-Agrege(ikl))*eta_SV(ikl,i ) & 352 + Agrege(ikl) *eta_SV(ikl,i+1)) 353 G1snSV(ikl,i) = (1.-staggr )*G1snSV(ikl,i ) & 354 + staggr*((1.-Agrege(ikl))*G1snSV(ikl,i ) & 355 + Agrege(ikl) *G1snSV(ikl,i+1)) 356 G2snSV(ikl,i) = (1.-staggr )*G2snSV(ikl,i ) & 357 + staggr*((1.-Agrege(ikl))*G2snSV(ikl,i ) & 358 + Agrege(ikl) *G2snSV(ikl,i+1)) 359 agsnSV(ikl,i) = (1.-staggr )*agsnSV(ikl,i ) & 360 + staggr*((1.-Agrege(ikl))*agsnSV(ikl,i ) & 361 + Agrege(ikl) *agsnSV(ikl,i+1)) 362 END DO 363 END DO 364 365 DO ikl=1,knonv 366 isn = min(isnoSV(ikl) +1,nsno) 367 istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn) 368 dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn) 369 TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn) 370 ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn) 371 eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn) 372 G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn) 373 G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn) 374 agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn) 375 END DO 376 377 378 379 380 ! +--Constrains Splitting of too thick Layers 381 ! + ================================================= 382 383 384 ! +--Search the thickest non-zero Layer 385 ! + ---------------------------------- 386 387 DO ikl=1,knonv 388 dzthin(ikl) = 0. ! Arbitrary unrealistic 389 END DO 390 DO ikl=1,knonv 391 DO isn=1,isnoSV(ikl) 392 isno_n = isnoSV(ikl)-isn+1 ! Snow Normal.Profile 393 iice_n = iiceSV(ikl)-isn ! Ice Normal.Profile 394 iiceOK = min(1,max(0,iice_n +1)) ! Ice Switch 395 dz_dif =( dzsnSV(ikl,isn) & ! Actual Profile 396 - dz_max *((1-iiceOK)*isno_n*isno_n & ! Theoretical Profile 397 + iiceOK *2. **iice_n) ) & ! 398 /max(dzsnSV(ikl,isn),epsi) ! 399 OKthin = max(zero, & ! 400 sign(unun, & ! 401 dz_dif-dzthin(ikl))) & ! 1.=>New thickest Lay. 402 * max(0, & ! 1 =>.le. isnoSV 403 min(1, & ! 404 isnoSV(ikl)-isn +1 )) ! 405 i_thin(ikl) = (1. - OKthin) * i_thin(ikl) & ! Update thickest Lay. 406 + OKthin * isn ! Index 407 dzthin(ikl) = (1. - OKthin) * dzthin(ikl) & ! 408 + OKthin * dz_dif ! 409 END DO 410 411 isn=max(1,isnoSV(ikl)-3) 412 if(dzsnSV(ikl,isn)>0.30) then ! surface layer > 30cm 413 i_thin(ikl) = isn ! XF 04/07/2019 414 dzthin(ikl) = dzsnSV(ikl,isn) 415 endif 416 417 isn=max(1,isnoSV(ikl)-2) 418 if(dzsnSV(ikl,isn)>0.10) then ! surface layer > 10cm 419 i_thin(ikl) = isn ! XF 04/07/2019 420 dzthin(ikl) = dzsnSV(ikl,isn) 421 endif 422 423 isn=max(1,isnoSV(ikl)-1) 424 if(dzsnSV(ikl,isn)>0.05) then ! surface layer > 5cm 425 i_thin(ikl) = isn ! XF 04/07/2019 426 dzthin(ikl) = dzsnSV(ikl,isn) 427 endif 428 429 isn=max(1,isnoSV(ikl)) 430 if(dzsnSV(ikl,isn)>0.02) then ! surface layer > 2cm 431 i_thin(ikl) = isn ! XF 04/07/2019 432 dzthin(ikl) = dzsnSV(ikl,isn) 433 endif 434 435 END DO 436 437 DO ikl=1,knonv 438 ThickL = max(zero, & ! 1. => a too thick 439 sign(unun,dzthin(ikl) & ! Layer exists 440 -epsi )) & ! 441 * max(0,1-max(0 , isnoSV(ikl) & ! No spliting allowed 442 -nsno+1 )) ! if isno > nsno - 1 443 Agrege(ikl) = ThickL & ! 1. => effective split 444 * max(0,1-max(0 , NLaysv(ikl) & ! 445 +isnoSV(ikl) & ! 446 -nsno+1 )) ! 447 NLay_s(ikl) = ThickL & ! Agregation 448 * max(0,1-max(0 , NLaysv(ikl) & ! to allow Splitting 449 +isnoSV(ikl) & ! at next Time Step 450 -nsno )) & ! 451 -Agrege(ikl) ! 452 NLay_s(ikl) = max(0 , NLay_s(ikl)) ! Agregation effective 453 END DO 454 455 456 ! +--Rearranges the Layers 457 ! + --------------------- 458 459 DO isn=nsno,2,-1 460 DO ikl=1,knonv 461 IF (Agrege(ikl).gt.0..AND.i_thin(ikl).lt.isnoSV(ikl)) THEN 462 staggr = min(1,max(0,isn-i_thin(ikl) -1)) & 463 * min(1,max(0, isnoSV(ikl)-isn+2)) 464 istoSV(ikl,isn) = staggr * istoSV(ikl ,isn-1) & 465 + (1. - staggr) * istoSV(ikl ,isn ) 466 dzsnSV(ikl,isn) = staggr * dzsnSV(ikl ,isn-1) & 467 + (1. - staggr) * dzsnSV(ikl ,isn ) 468 TsisSV(ikl,isn) = staggr * TsisSV(ikl ,isn-1) & 469 + (1. - staggr) * TsisSV(ikl ,isn ) 470 ro__SV(ikl,isn) = staggr * ro__SV(ikl ,isn-1) & 471 + (1. - staggr) * ro__SV(ikl ,isn ) 472 eta_SV(ikl,isn) = staggr * eta_SV(ikl ,isn-1) & 473 + (1. - staggr) * eta_SV(ikl ,isn ) 474 G1snSV(ikl,isn) = staggr * G1snSV(ikl ,isn-1) & 475 + (1. - staggr) * G1snSV(ikl ,isn ) 476 G2snSV(ikl,isn) = staggr * G2snSV(ikl ,isn-1) & 477 + (1. - staggr) * G2snSV(ikl ,isn ) 478 agsnSV(ikl,isn) = staggr * agsnSV(ikl ,isn-1) & 479 + (1. - staggr) * agsnSV(ikl ,isn ) 480 END IF 481 END DO 482 END DO 483 484 DO ikl=1,knonv 485 isn = i_thin(ikl) 486 dzsnSV(ikl,isn) = 0.5*Agrege(ikl) *dzsnSV(ikl,isn) & 487 + (1.-Agrege(ikl))*dzsnSV(ikl,isn) 488 489 isn = min(i_thin(ikl) +1,nsno) 490 istoSV(ikl,isn) = Agrege(ikl) *istoSV(ikl,isn-1) & 491 + (1.-Agrege(ikl))*istoSV(ikl,isn) 492 dzsnSV(ikl,isn) = Agrege(ikl) *dzsnSV(ikl,isn-1) & 493 + (1.-Agrege(ikl))*dzsnSV(ikl,isn) 494 TsisSV(ikl,isn) = Agrege(ikl) *TsisSV(ikl,isn-1) & 495 + (1.-Agrege(ikl))*TsisSV(ikl,isn) 496 ro__SV(ikl,isn) = Agrege(ikl) *ro__SV(ikl,isn-1) & 497 + (1.-Agrege(ikl))*ro__SV(ikl,isn) 498 eta_SV(ikl,isn) = Agrege(ikl) *eta_SV(ikl,isn-1) & 499 + (1.-Agrege(ikl))*eta_SV(ikl,isn) 500 G1snSV(ikl,isn) = Agrege(ikl) *G1snSV(ikl,isn-1) & 501 + (1.-Agrege(ikl))*G1snSV(ikl,isn) 502 G2snSV(ikl,isn) = Agrege(ikl) *G2snSV(ikl,isn-1) & 503 + (1.-Agrege(ikl))*G2snSV(ikl,isn) 504 agsnSV(ikl,isn) = Agrege(ikl) *agsnSV(ikl,isn-1) & 505 + (1.-Agrege(ikl))*agsnSV(ikl,isn) 506 isnoSV(ikl) = min(Agrege(ikl) +isnoSV(ikl),real(nsno)) 507 iiceSV(ikl) = iiceSV(ikl) & 508 + Agrege(ikl) *max(0,sign(1,iiceSV(ikl) & 509 -isn +icemix)) & 510 *max(0,sign(1,iiceSV(ikl) & 511 -1 )) 512 END DO 513 514 515 ! +--Constrains Agregation in case of too much Layers 516 ! + ================================================= 517 518 ! +--Search the thinest non-zero Layer 519 ! + ----------------------------------- 520 521 522 523 DO ikl=1,knonv 524 dzthin(ikl) = 0. ! Arbitrary unrealistic 525 END DO ! Layer Thickness 526 DO ikl=1,knonv 527 DO isn=1,isnoSV(ikl)-3 ! no agregation of 3 first snowlayers 528 ! ! XF 04/07/2019 529 530 isno_n = isnoSV(ikl)-isn+1 ! Snow Normal.Profile 531 iice_n = iiceSV(ikl)-isn ! Ice Normal.Profile 532 iiceOK = min(1,max(0,iice_n +1)) ! Ice Switch 533 ! #vz dz_ref(isn) = ! 534 ! #vz. dz_min *((1-iiceOK)*isno_n*isno_n ! Theoretical Profile 535 ! #vz. + iiceOK * 2**iice_n) ! 536 ! #vz. /max(1,isnoSV(ikl)) ! 537 dz_dif = dz_min & ! Actual Profile 538 - dzsnSV(ikl ,isn) & ! 539 /max(epsi,((1-iiceOK)*isno_n*isno_n & ! Theoretical Profile 540 + iiceOK *2. **iice_n)) ! 541 ! #vz dzwdif(isn) = dz_dif ! 542 OKthin = max(zero, & ! 543 sign(unun, & ! 544 dz_dif - dzthin(ikl))) & ! 1.=> New thinest Lay. 545 * max(0, & ! 1 => .le. isnoSV 546 min(1, & ! 547 isnoSV(ikl)-isn +1 )) ! 548 i_thin(ikl) = (1. - OKthin) * i_thin(ikl) & ! Update thinest Lay. 549 + OKthin * isn ! Index 550 dzthin(ikl) = (1. - OKthin) * dzthin(ikl) & ! 551 + OKthin * dz_dif ! 552 553 554 END DO 555 END DO 556 557 558 559 560 561 ! +--Index of the contiguous Layer to agregate 562 ! + ----------------------------------------- 563 564 ! + *************** 565 call SISVAT_zCr 566 ! + *************** 567 568 569 ! +--Assign the 2 Layers to agregate 570 ! + ------------------------------- 571 572 DO ikl=1,knonv 573 isn = i_thin(ikl) 574 if(LIndsv(ikl)>0) isn=min(isn, nsno-1) !cXF 575 isagr1(ikl) = istoSV(ikl,isn) 576 isagr2(ikl) = istoSV(ikl,isn+LIndsv(ikl)) 577 dzagr1(ikl) = dzsnSV(ikl,isn) 578 dzagr2(ikl) = dzsnSV(ikl,isn+LIndsv(ikl)) 579 T_agr1(ikl) = TsisSV(ikl,isn) 580 T_agr2(ikl) = TsisSV(ikl,isn+LIndsv(ikl)) 581 roagr1(ikl) = ro__SV(ikl,isn) 582 roagr2(ikl) = ro__SV(ikl,isn+LIndsv(ikl)) 583 etagr1(ikl) = eta_SV(ikl,isn) 584 etagr2(ikl) = eta_SV(ikl,isn+LIndsv(ikl)) 585 G1agr1(ikl) = G1snSV(ikl,isn) 586 G1agr2(ikl) = G1snSV(ikl,isn+LIndsv(ikl)) 587 G2agr1(ikl) = G2snSV(ikl,isn) 588 G2agr2(ikl) = G2snSV(ikl,isn+LIndsv(ikl)) 589 agagr1(ikl) = agsnSV(ikl,isn) 590 agagr2(ikl) = agsnSV(ikl,isn+LIndsv(ikl)) 591 LstLay = min(1,max( 0, isnoSV(ikl)-1 )) 592 Agrege(ikl) = min(1, & 593 max(0, & 594 NLaysv(ikl) +isnoSV(ikl)-nsno & 595 +NLay_s(ikl) ) & 596 *LstLay ) 597 598 ! + minimum uppermost layer thickness to guarantee a correct reproduction of the snow 599 ! + atmosphere coupling 600 if(dzsnSV(ikl,max(1,isnoSV(ikl)-0))>0.02 .or. & ! surface layers> 2-5-10 601 dzsnSV(ikl,max(1,isnoSV(ikl)-1))>0.05 .or. & ! XF 04/07/2019 602 dzsnSV(ikl,max(1,isnoSV(ikl)-2))>0.10 .or. & 603 dzsnSV(ikl,max(1,isnoSV(ikl)-3))>0.30 )then 604 Agrege(ikl) = min(1, & 605 max(0, & 606 NLaysv(ikl) +isnoSV(ikl)+1-nsno & ! nsno-1 layers ma 607 +NLay_s(ikl) ) & 608 *LstLay ) 609 endif 610 611 isnoSV(ikl) = isnoSV(ikl) & 612 -(1-LstLay)*max(zero, & 613 sign(unun, eps_21 & 614 -dzsnSV(ikl,1) )) 615 isnoSV(ikl) =max( 0, isnoSV(ikl) ) 616 617 WEagre(ikl) = 0. 618 END DO 619 620 DO isn=1,nsno 621 DO ikl=1,knonv 622 WEagre(ikl) = WEagre(ikl) + ro__SV(ikl,isn)*dzsnSV(ikl,isn) & 623 *min(1,max(0,i_thin(ikl)+1-isn)) 624 ENDDO 625 ENDDO 626 627 ! +--Agregates 628 ! + --------- 629 630 ! + *************** 631 call SISVAT_zAg & 632 (isagr1,isagr2,WEagre & 633 ,dzagr1,dzagr2,T_agr1,T_agr2 & 634 ,roagr1,roagr2,etagr1,etagr2 & 635 ,G1agr1,G1agr2,G2agr1,G2agr2 & 636 ,agagr1,agagr2,Agrege & 637 ) 638 ! + *************** 639 640 641 ! +--Rearranges the Layers 642 ! + --------------------- 643 644 ! +--New (agregated) Snow layer 645 ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ 646 DO ikl=1,knonv 647 isn = i_thin(ikl) 648 isn = min(isn,isn+LIndsv(ikl)) 649 isnoSV(ikl) = max(0.,isnoSV(ikl) -Agrege(ikl)) 650 iiceSV(ikl) = iiceSV(ikl) & 651 -max(0,sign(1,iiceSV(ikl) -isn +icemix)) & 652 *Agrege(ikl) & 653 *max(0,sign(1,iiceSV(ikl) -1 )) 654 istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn) & 655 + Agrege(ikl) *isagr1(ikl) 656 dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn) & 657 + Agrege(ikl) *dzagr1(ikl) 658 TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn) & 659 + Agrege(ikl) *T_agr1(ikl) 660 ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn) & 661 + Agrege(ikl) *roagr1(ikl) 662 eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn) & 663 + Agrege(ikl) *etagr1(ikl) 664 G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn) & 665 + Agrege(ikl) *G1agr1(ikl) 666 G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn) & 667 + Agrege(ikl) *G2agr1(ikl) 668 agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn) & 669 + Agrege(ikl) *agagr1(ikl) 670 END DO 671 672 ! +--Above 673 ! + ^^^^^ 674 DO ikl=1,knonv 675 isn1(ikl)=max(i_thin(ikl),i_thin(ikl)+LIndsv(ikl)) 676 END DO 677 DO i= 1,nsno-1 678 DO ikl=1,knonv 679 staggr = min(1,max(0,i +1 -isn1(ikl) )) 680 istoSV(ikl,i) = (1.-staggr )*istoSV(ikl,i ) & 681 + staggr*((1.-Agrege(ikl))*istoSV(ikl,i ) & 682 + Agrege(ikl) *istoSV(ikl,i+1)) 683 dzsnSV(ikl,i) = (1.-staggr )*dzsnSV(ikl,i ) & 684 + staggr*((1.-Agrege(ikl))*dzsnSV(ikl,i ) & 685 + Agrege(ikl) *dzsnSV(ikl,i+1)) 686 TsisSV(ikl,i) = (1.-staggr )*TsisSV(ikl,i ) & 687 + staggr*((1.-Agrege(ikl))*TsisSV(ikl,i ) & 688 + Agrege(ikl) *TsisSV(ikl,i+1)) 689 ro__SV(ikl,i) = (1.-staggr )*ro__SV(ikl,i ) & 690 + staggr*((1.-Agrege(ikl))*ro__SV(ikl,i ) & 691 + Agrege(ikl) *ro__SV(ikl,i+1)) 692 eta_SV(ikl,i) = (1.-staggr )*eta_SV(ikl,i ) & 693 + staggr*((1.-Agrege(ikl))*eta_SV(ikl,i ) & 694 + Agrege(ikl) *eta_SV(ikl,i+1)) 695 G1snSV(ikl,i) = (1.-staggr )*G1snSV(ikl,i ) & 696 + staggr*((1.-Agrege(ikl))*G1snSV(ikl,i ) & 697 + Agrege(ikl) *G1snSV(ikl,i+1)) 698 G2snSV(ikl,i) = (1.-staggr )*G2snSV(ikl,i ) & 699 + staggr*((1.-Agrege(ikl))*G2snSV(ikl,i ) & 700 + Agrege(ikl) *G2snSV(ikl,i+1)) 701 agsnSV(ikl,i) = (1.-staggr )*agsnSV(ikl,i ) & 702 + staggr*((1.-Agrege(ikl))*agsnSV(ikl,i ) & 703 + Agrege(ikl) *agsnSV(ikl,i+1)) 704 END DO 705 END DO 706 707 DO ikl=1,knonv 708 isn = min(isnoSV(ikl) +1,nsno) 709 istoSV(ikl,isn) = (1.-Agrege(ikl))*istoSV(ikl,isn) 710 dzsnSV(ikl,isn) = (1.-Agrege(ikl))*dzsnSV(ikl,isn) 711 TsisSV(ikl,isn) = (1.-Agrege(ikl))*TsisSV(ikl,isn) 712 ro__SV(ikl,isn) = (1.-Agrege(ikl))*ro__SV(ikl,isn) 713 eta_SV(ikl,isn) = (1.-Agrege(ikl))*eta_SV(ikl,isn) 714 G1snSV(ikl,isn) = (1.-Agrege(ikl))*G1snSV(ikl,isn) 715 G2snSV(ikl,isn) = (1.-Agrege(ikl))*G2snSV(ikl,isn) 716 agsnSV(ikl,isn) = (1.-Agrege(ikl))*agsnSV(ikl,isn) 717 END DO 718 719 720 ! +--Search new Ice/Snow Interface (option II in MAR) 721 ! + =============================================== 722 723 IF (ok_zsn_ii) THEN 724 725 DO ikl=1,knonv 726 iiceSV(ikl) = 0 727 END DO 728 729 DO ikl=1,knonv 730 DO isn=1,isnoSV(ikl) 731 OK_ICE = max(zero,sign(unun,ro__SV(ikl,isn)-ro_ice+20.)) & 732 * max(zero,sign(unun,dzsnSV(ikl,isn)-epsi)) 733 iiceSV(ikl) = (1.-OK_ICE) *iiceSV(ikl) & 734 + OK_ICE *isn 735 END DO 736 END DO 737 738 END IF 739 740 return 741 end subroutine sisvat_zsn
Note: See TracChangeset
for help on using the changeset viewer.
