Changeset 14062
- Timestamp:
- 2020-12-03T17:39:30+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG
- Files:
-
- 21 deleted
- 99 edited
- 7 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/AGRIF_DEMO/EXPREF/1_namelist_cfg
r14037 r14062 299 299 !----------------------------------------------------------------------- 300 300 ln_dynvor_een = .true. ! energy & enstrophy scheme 301 nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4302 301 / 303 302 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/AGRIF_DEMO/EXPREF/namelist_cfg
r14037 r14062 300 300 !----------------------------------------------------------------------- 301 301 ln_dynvor_een = .true. ! energy & enstrophy scheme 302 nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4303 302 / 304 303 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/AMM12/EXPREF/namelist_cfg
r14037 r14062 291 291 !----------------------------------------------------------------------- 292 292 ln_dynvor_een = .true. ! energy & enstrophy scheme 293 nn_een_e3f = 1! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)293 nn_e3f_typ = 1 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 294 294 / 295 295 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg
r14037 r14062 334 334 !----------------------------------------------------------------------- 335 335 ln_dynvor_een = .true. ! energy & enstrophy scheme 336 nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4337 336 / 338 337 !----------------------------------------------------------------------- … … 389 388 ! ! = 3 as =2 with distinct dissipative an mixing length scale 390 389 nn_etau = 1 ! penetration of tke below the mixed layer (ML) due to NIWs 391 392 393 390 ! ! = 0 none ; = 1 add a tke source below the ML 391 ! ! = 2 add a tke source just at the base of the ML 392 ! ! = 3 as = 1 applied on HF part of the stress (ln_cpl=T) 394 393 ln_mxhsw = .false. ! surface mixing length scale = F(wave height) 395 394 / -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/axis_def_nemo.xml
r12377 r14062 14 14 <axis id="depthv" long_name="Vertical V levels" unit="m" positive="down" /> 15 15 <axis id="depthw" long_name="Vertical W levels" unit="m" positive="down" /> 16 <axis id="depthf" long_name="Vertical F levels" unit="m" positive="down" /> 16 17 <axis id="nfloat" long_name="Float number" unit="-" /> 17 18 <axis id="icbcla" long_name="Iceberg class" unit="1" /> -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/domain_def_nemo.xml
r12276 r14062 181 181 <domain id="EqW" domain_ref="grid_W" > <zoom_domain id="EqW"/> </domain> 182 182 183 <!-- F grid --> 184 <domain id="grid_F" long_name="grid F"/> 185 183 186 <!-- zonal mean grid --> 184 187 <domain_group id="gznl"> -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/field_def_nemo-oce.xml
r14037 r14062 171 171 <field id="tosmint_pot" long_name="vertical integral of potential temperature times density" standard_name="integral_wrt_depth_of_product_of_density_and_potential_temperature" unit="(kg m2) degree_C" /> 172 172 173 173 <field id="ht" long_name="water column height at T point" standard_name="water_column_height_T" unit="m" /> 174 174 <field id="ssh" long_name="sea surface height" standard_name="sea_surface_height_above_geoid" unit="m" /> 175 175 <field id="ssh2" long_name="square of sea surface height" standard_name="square_of_sea_surface_height_above_geoid" unit="m2" > ssh * ssh </field > … … 190 190 191 191 <!-- Energy - horizontal divergence --> 192 <field id="sKE" long_name="surface kinetic energy" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" grid_ref="grid_T_2D" /> 192 193 <field id="hdiv" long_name="horizontal divergence" unit="s-1" grid_ref="grid_T_3D" /> 193 194 … … 270 271 271 272 <field_group id="OSMOSIS_T" grid_ref="grid_T_2D"> 273 <field id="hml" long_name="mixed layr depth" unit="m" /> 274 <field id="hbl" long_name="boundary layer depth" unit="m" /> 275 <field id="dh" long_name="Pycnocline thickness" unit=" m" /> 276 <field id="ibld" long_name="index of boundary layer depth" unit="#" /> 277 <field id="imld" long_name="index of mixed layer depth" unit="#" /> 278 <field id="zhbl" long_name="boundary layer depth -grid" unit="m" /> 279 <field id="zhml" long_name="mixed layer depth - grid" unit="m" /> 280 <field id="zdh" long_name="Pycnocline depth - grid" unit=" m" /> 281 <field id="zustke" long_name="magnitude of stokes drift at T-points" unit="m/s" /> 282 <field id="us_x" long_name="i component of active Stokes drift" unit="m/s" /> 283 <field id="us_y" long_name="j component of active Stokes drift" unit="m/s" /> 284 <field id="dstokes" long_name="stokes drift depth scale" unit="m" /> 272 285 <field id="zwth0" long_name="surface non-local temperature flux" unit="deg m/s" /> 273 286 <field id="zws0" long_name="surface non-local salinity flux" unit="psu m/s" /> 274 <field id="hbl" long_name="boundary layer depth" unit="m" />275 <field id="hbli" long_name="initial boundary layer depth" unit="m" />276 <field id="dstokes" long_name="stokes drift depth scale" unit="m" />277 <field id="zustke" long_name="magnitude of stokes drift at T-points" unit="m/s" />278 287 <field id="zwstrc" long_name="convective velocity scale" unit="m/s" /> 288 <field id="zustar" long_name="friction velocity" unit="m/s" /> 279 289 <field id="zwstrl" long_name="langmuir velocity scale" unit="m/s" /> 280 <field id="zustar" long_name="friction velocity" unit="m/s" /> 281 <field id="zhbl" long_name="boundary layer depth" unit="m" /> 282 <field id="zhml" long_name="mixed layer depth" unit="m" /> 290 <field id="zvstr" long_name="mixed velocity scale" unit="m/s" /> 291 <field id="zla" long_name="langmuir number" unit="m/s" /> 283 292 <field id="wind_wave_abs_power" long_name="\rho |U_s| x u*^2" unit="mW" /> 284 293 <field id="wind_wave_power" long_name="U_s \dot tau" unit="mW" /> 285 294 <field id="wind_power" long_name="\rho u*^3" unit="mW" /> 286 295 287 <!-- extraOSMOSIS diagnostics -->296 <!-- interior BL OSMOSIS diagnostics --> 288 297 <field id="zwthav" long_name="av turb flux of T in ml" unit="deg m/s" /> 289 298 <field id="zt_ml" long_name="av T in ml" unit="deg" /> 299 <field id="zhol" long_name="Hoenekker number" unit="#" /> 300 <field id="zws_ent" long_name="entrainment turb flux of S" unit="10^-3 m/s" /> 290 301 <field id="zwth_ent" long_name="entrainment turb flux of T" unit="deg m/s" /> 291 <field id="zhol" long_name="Hoenekker number" unit="#" /> 292 <field id="zdh" long_name="Pycnocline depth - grid" unit=" m" /> 293 </field_group> 294 295 <field_group id="OSMOSIS_W" grid_ref="grid_W_3D" operation="instant" > 302 <field id="zwb_ent" long_name="entrainment turb flux of buoyancy" unit="m^2/s^-3" /> 303 304 <field id="zdt_bl" long_name="temperature jump at base of BL" unit="deg" /> 305 <field id="zds_bl" long_name="salinity jump at base of BL" unit="10^-3" /> 306 <field id="zdb_bl" long_name="buoyancy jump at base of BL" unit="m/s^2" /> 307 <field id="zdu_bl" long_name="u jump at base of BL" unit="m/s" /> 308 <field id="zdv_bl" long_name="v jump at base of BL" unit="m/s" /> 309 310 <!-- extra OSMOSIS diagnostics for debugging --> 311 <field id="zsc_uw_1_0" long_name="zsc u-momentum flux on T after Stokes" unit="m^2/s^2" /> 312 <field id="zsc_uw_1_f" long_name="zsc u-momentum flux on T after Coriolis" unit="m^2/s^2" /> 313 <field id="zsc_vw_1_f" long_name="zsc v-momentum flux on T after Coriolis" unit="m^2/s^2" /> 314 <field id="zsc_uw_2_f" long_name="2nd zsc u-momentum flux on T after Coriolis" unit="m^2/s^2" /> 315 <field id="zsc_vw_2_f" long_name="2nd zsc v-momentum flux on T after Coriolis" unit="m^2/s^2" /> 316 <field id="zuw_bse" long_name="base u-flux T-points" unit="m^2/s^2" /> 317 <field id="zvw_bse" long_name="base v-flux T-points" unit="m^2/s^2" /> 318 319 <!-- FK_OSM OSMOSIS diagnostics (require also ln_osm_mle=.true.--> 320 <field id="hmle" long_name="OBL FK-layer thickness" unit="m" /> 321 <field id="mld_prof" long_name="FK-layer depth index" unit="#" /> 322 <field id="zmld" long_name="target FK-layer thickness" unit="m" /> 323 <field id="zwb_fk" long_name="FK b-flux" unit="m^2 s^-3" /> 324 <field id="zwb_fk_b" long_name="layer averaged FK b-flux" unit="m^2 s^-3" /> 325 <field id="zdiff_mle" long_name="max FK diffusivity in MLE" unit=" 10^-4 m^2 s^-1" /> 326 <field id="zvel_mle" long_name="FK velocity scale in MLE" unit=" m s^-1" /> 327 </field_group> 328 329 <field_group id="OSMOSIS_W" grid_ref="grid_W_3D" > 330 <field id="zviscos" long_name="BL viscosity" unit="m^2/s" /> 296 331 <field id="ghamt" long_name="non-local temperature flux" unit="deg m/s" /> 297 332 <field id="ghams" long_name="non-local salinity flux" unit="psu m/s" /> 298 333 <field id="zdtdz_pyc" long_name="Pycnocline temperature gradient" unit=" deg/m" /> 299 </field_group> 334 <field id="zdsdz_pyc" long_name="Pycnocline salinity gradient" unit=" 10^-3/m" /> 335 <field id="zdbdz_pyc" long_name="Pycnocline buoyancy gradient" unit=" s^-2" /> 336 <field id="zdudz_pyc" long_name="Pycnocline u gradient" unit=" s^-2" /> 337 <field id="zdvdz_pyc" long_name="Pycnocline v gradient" unit=" s^-2" /> 338 339 <!-- extra OSMOSIS diagnostics for debugging --> 340 <field id="ghamu_00" long_name="initial non-local u-momentum flux" unit="m^2/s^2" /> 341 <field id="ghamv_00" long_name="initial non-local v-momentum flux" unit="m^2/s^2" /> 342 <field id="ghamu_0" long_name="after dstokes non-local u-momentum flux" unit="m^2/s^2" /> 343 <field id="ghamu_f" long_name="after Coriolis non-local u-momentum flux" unit="m^2/s^2" /> 344 <field id="ghamv_f" long_name="after Coriolis non-local v-momentum flux" unit="m^2/s^2" /> 345 <field id="ghamu_b" long_name="after buoyancy added non-local u-momentum flux" unit="m^2/s^2" /> 346 <field id="ghamv_b" long_name="after buoyancy added non-local v-momentum flux" unit="m^2/s^2" /> 347 <field id="ghamu_1" long_name="after entrainment non-local u-momentum flux" unit="m^2/s^2" /> 348 <field id="ghamv_1" long_name="after entrainment non-local v-momentum flux" unit="m^2/s^2" /> 349 </field_group> 300 350 301 351 <field_group id="OSMOSIS_U" grid_ref="grid_U_2D" > 302 352 <field id="ghamu" long_name="non-local u-momentum flux" grid_ref="grid_U_3D" unit="m^2/s^2" /> 303 <field id="us_x" long_name="i component of Stokes drift" unit="m/s" /> 304 </field_group> 353 <!-- FK_OSM OSMOSIS diagnostics (require also ln_osm_mle=.true.--> 354 <field id="zdtdx" long_name="FK T x-gradient" unit=" deg C m^-1" /> 355 <field id="zdsdx" long_name="FK S x-gradient" unit=" 10^-3 m^-1" /> 356 <field id="dbdx_mle" long_name="FK B x-gradient" unit=" s^-2" /> 357 </field_group> 305 358 306 359 <field_group id="OSMOSIS_V" grid_ref="grid_V_2D" > 307 360 <field id="ghamv" long_name="non-local v-momentum flux" grid_ref="grid_V_3D" unit="m^2/s^2" /> 308 <field id="us_y" long_name="j component of Stokes drift" unit="m/s" /> 361 <!-- FK_OSM OSMOSIS diagnostics (require also ln_osm_mle=.true.--> 362 <field id="zdtdy" long_name="FK T y-gradient" unit=" deg C m^-1" /> 363 <field id="zdsdy" long_name="FK S y-gradient" unit=" 10^-3 m^-1" /> 364 <field id="dbdy_mle" long_name="FK B y-gradient" unit=" s^-2" /> 309 365 </field_group> 310 366 … … 501 557 502 558 <field_group id="grid_U" grid_ref="grid_U_2D"> 559 <field id="hu" long_name="water column height at U point" standard_name="water_column_height_U" unit="m" /> 503 560 <field id="e2u" long_name="U-cell width in meridional direction" standard_name="cell_width" unit="m" /> 504 561 <field id="e3u" long_name="U-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_U_3D" /> … … 571 628 <field id="e3v" long_name="V-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_V_3D" /> 572 629 <field id="e3v_0" long_name="Initial V-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_V_3D" /> 630 <field id="hv" long_name="water column height at V point" standard_name="water_column_height_V" unit="m" /> 573 631 <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" /> 574 632 <field id="voce" long_name="ocean current along j-axis" standard_name="sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" /> … … 679 737 680 738 <!-- F grid --> 739 <field_group id="grid_F" grid_ref="grid_F_2D"> 740 <field id="e3f" long_name="F-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_F_3D" /> 741 <field id="e3f_0" long_name="F-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_F_3D" /> 742 <field id="hf" long_name="water column height at F point" standard_name="water_column_height_F" unit="m" /> 743 <field id="sKEf" long_name="surface kinetic energy at F point" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" /> 744 <field id="relvor" long_name="relative vorticity" standard_name="relative_vorticity" unit="1/s" /> 745 <field id="plavor" long_name="planetary vorticity" standard_name="planetary_vorticity" unit="1/s" /> 746 <field id="relpotvor" long_name="relative potential vorticity" standard_name="relpot_vorticity" unit="1/m.s" /> 747 <field id="abspotvor" long_name="absolute potential vorticity" standard_name="abspot_vorticity" unit="1/m.s" /> 748 <field id="Ens" long_name="enstrophy" standard_name="enstrophy" unit="1/m2.s2" /> 749 </field_group> 750 681 751 <!-- AGRIF sponge --> 682 752 <field id="agrif_spf" long_name=" AGRIF f-sponge coefficient" unit=" " /> … … 841 911 <field id="strd_zdfp" long_name="salinity -trend: pure vert. diffusion" unit="1e-3/s" /> 842 912 843 <!-- --> 913 <!-- ln_zdfosm=T only (OSMOSIS-OBL) --> 914 <field id="ttrd_osm" long_name="temperature-trend: OSM-OSBL non-local forcing" unit="degC/s" /> 915 <field id="strd_osm" long_name="salinity -trend: OSM-OSBL non-local forcing" unit="1e-3/s" /> 916 917 918 <!-- --> 844 919 <field id="ttrd_dmp" long_name="temperature-trend: interior restoring" unit="degC/s" /> 845 920 <field id="strd_dmp" long_name="salinity -trend: interior restoring" unit="1e-3/s" /> … … 877 952 <field id="strd_zdfp_e3t" unit="1e-3/s * m" > strd_zdfp * e3t </field> 878 953 954 <!-- ln_zdfosm=T only (OSMOSIS-OBL) --> 955 <field id="ttrd_osm_e3t" long_name="temperature-trend: OSM-OSBL non-local forcing" unit="degC/s * m" > ttrd_osm * e3t </field> 956 <field id="strd_osm_e3t" long_name="salinity -trend: OSM-OSBL non-local forcing" unit="1e-3/s * m" > strd_osm * e3t </field> 957 879 958 <!-- --> 880 959 <field id="ttrd_dmp_e3t" unit="degC/s * m" > ttrd_dmp * e3t </field> … … 892 971 <field id="ttrd_totad_li" long_name="layer integrated heat-trend: total advection" unit="W/m^2" > ttrd_totad_e3t * 1026.0 * 3991.86795711963 </field> 893 972 <field id="strd_totad_li" long_name="layer integrated salt-trend: total advection" unit="kg/(m^2 s)" > strd_totad_e3t * 1026.0 * 0.001 </field> 973 <field id="ttrd_osm_li" long_name="layer integrated heat-trend: non-local OSM" unit="W/m^2" > ttrd_osm_e3t * 1026.0 * 3991.86795711963 </field> 974 <field id="strd_osm_li" long_name="layer integrated salt-trend: non-local OSM" unit="kg/(m^2 s)" > strd_osm_e3t * 1026.0 * 0.001 </field> 894 975 <field id="ttrd_evd_li" long_name="layer integrated heat-trend: EVD convection" unit="W/m^2" > ttrd_evd_e3t * 1026.0 * 3991.86795711963 </field> 895 976 <field id="strd_evd_li" long_name="layer integrated salt-trend: EVD convection" unit="kg/(m^2 s)" > strd_evd_e3t * 1026.0 * 0.001 </field> … … 1099 1180 </field_group> 1100 1181 1182 <!-- TMB diagnostic output --> 1183 <field_group id="1h_grid_T_tmb" grid_ref="grid_T_2D" operation="instant"> 1184 <field id="top_temp" name="votemper_top" unit="degC" /> 1185 <field id="mid_temp" name="votemper_mid" unit="degC" /> 1186 <field id="bot_temp" name="votemper_bot" unit="degC" /> 1187 <field id="top_sal" name="vosaline_top" unit="psu" /> 1188 <field id="mid_sal" name="vosaline_mid" unit="psu" /> 1189 <field id="bot_sal" name="vosaline_bot" unit="psu" /> 1190 <field id="sshnmasked" name="sossheig" unit="m" /> 1191 </field_group> 1192 1101 1193 <field_group id="1h_grid_U_tmb" grid_ref="grid_U_2D" operation="instant"> 1102 1194 <field id="top_u" name="vozocrtx_top" unit="m/s" /> -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/grid_def_nemo.xml
r12377 r14062 53 53 <domain domain_ref="grid_W" /> 54 54 <axis axis_ref="depthw" /> 55 </grid> 56 <!-- --> 57 <grid id="grid_F_2D" > 58 <domain domain_ref="grid_F" /> 59 </grid> 60 <!-- --> 61 <grid id="grid_F_3D" > 62 <domain domain_ref="grid_F" /> 63 <axis axis_ref="depthf" /> 55 64 </grid> 56 65 <!-- --> -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/cfgs/SHARED/namelist_ref
r14044 r14062 998 998 ln_dynvor_eeT = .false. ! energy conserving scheme (een using e3t) 999 999 ln_dynvor_een = .false. ! energy & enstrophy scheme 1000 nn_een_e3f = 0 ! =0 e3f = mi(mj(e3t))/4 1001 ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) 1000 ! 1002 1001 ln_dynvor_msk = .false. ! vorticity multiplied by fmask (=T) ==>>> PLEASE DO NOT ACTIVATE 1003 ! ! (f-point vorticity schemes only) 1002 ! ! (f-point vorticity schemes only) 1003 ! 1004 nn_e3f_typ = 0 ! type of e3f (EEN, ENE, ENS, MIX only) =0 e3f = mi(mj(e3t))/4 1005 ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) 1004 1006 / 1005 1007 !----------------------------------------------------------------------- … … 1011 1013 ln_hpg_isf = .false. ! s-coordinate (sco ) adapted to isf 1012 1014 ln_hpg_djc = .false. ! s-coordinate (Density Jacobian with Cubic polynomial) 1015 ln_hpg_djc_vnh = .true. ! hor. bc type for djc scheme (T=von Neumann, F=linear extrapolation) 1016 ln_hpg_djc_vnv = .true. ! vert. bc type for djc scheme (T=von Neumann, F=linear extrapolation) 1013 1017 ln_hpg_prj = .false. ! s-coordinate (Pressure Jacobian scheme) 1014 1018 / … … 1033 1037 ! ! Type of the operator : 1034 1038 ln_dynldf_OFF = .false. ! No operator (i.e. no explicit diffusion) 1039 nn_dynldf_typ = 0 ! =0 div-rot (default) ; =1 symmetric 1035 1040 ln_dynldf_lap = .false. ! laplacian operator 1036 1041 ln_dynldf_blp = .false. ! bilaplacian operator … … 1163 1168 ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F) 1164 1169 nn_mxlice = 2 ! type of scaling under sea-ice 1165 1166 1167 1168 1170 ! ! = 0 no scaling under sea-ice 1171 ! ! = 1 scaling with constant sea-ice thickness 1172 ! ! = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model ) 1173 ! ! = 3 scaling with maximum sea-ice thickness 1169 1174 rn_mxlice = 10. ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1) 1170 1175 rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value … … 1173 1178 rn_lc = 0.15 ! coef. associated to Langmuir cells 1174 1179 nn_etau = 1 ! penetration of tke below the mixed layer (ML) due to NIWs 1175 1176 1177 1180 ! ! = 0 none ; = 1 add a tke source below the ML 1181 ! ! = 2 add a tke source just at the base of the ML 1182 ! ! = 3 as = 1 applied on HF part of the stress (ln_cpl=T) 1178 1183 rn_efr = 0.05 ! fraction of surface tke value which penetrates below the ML (nn_etau=1 or 2) 1179 1184 nn_htau = 1 ! type of exponential decrease of tke penetration below the ML 1180 1181 1185 ! ! = 0 constant 10 m length scale 1186 ! ! = 1 0.5m at the equator to 30m poleward of 40 degrees 1182 1187 nn_eice = 1 ! attenutaion of langmuir & surface wave breaking under ice 1183 1188 ! ! = 0 no impact of ice cover on langmuir & surface wave breaking … … 1216 1221 &namzdf_osm ! OSM vertical diffusion (ln_zdfosm =T) 1217 1222 !----------------------------------------------------------------------- 1218 ln_use_osm_la = .false. ! Use namelistrn_osm_la1223 ln_use_osm_la = .false. ! Use rn_osm_la 1219 1224 rn_osm_la = 0.3 ! Turbulent Langmuir number 1220 rn_osm_dstokes = 5. ! Depth scale of Stokes drift (m) 1225 rn_zdfosm_adjust_sd = 1.0 ! Stokes drift reduction factor 1226 rn_osm_hblfrac = 0.1 ! specify top part of hbl for nn_osm_wave = 3 or 4 1227 rn_osm_bl_thresh = 5.e-5 !Threshold buoyancy for deepening of OSBL base 1221 1228 nn_ave = 0 ! choice of horizontal averaging on avt, avmu, avmv 1222 1229 ln_dia_osm = .true. ! output OSMOSIS-OBL variables … … 1226 1233 rn_difri = 0.005 ! max Ri# diffusivity at Ri_g = 0 (m^2/s) 1227 1234 ln_convmix = .true. ! Use convective instability mixing below BL 1228 rn_difconv = 1. ! diffusivity when unstable below BL (m2/s) 1235 rn_difconv = 1. !0.01 !1. ! diffusivity when unstable below BL (m2/s) 1236 rn_osm_dstokes = 5. ! Depth scale of Stokes drift (m) 1229 1237 nn_osm_wave = 0 ! Method used to calculate Stokes drift 1230 1238 ! ! = 2: Use ECMWF wave fields 1231 1239 ! ! = 1: Pierson Moskowitz wave spectrum 1232 1240 ! ! = 0: Constant La# = 0.3 1233 / 1241 nn_osm_SD_reduce = 0 ! Method used to get active Stokes drift from surface value 1242 ! ! = 0: No reduction 1243 ! = 1: use SD avged over top 10% hbl 1244 ! = 2:use surface value of SD fit to slope at rn_osm_hblfrac*hbl below surface 1245 ln_zdfosm_ice_shelter = .true. ! reduce surface SD and depth scale under ice 1246 ln_osm_mle = .false. ! Use integrated FK-OSM model 1247 / 1248 !----------------------------------------------------------------------- 1249 &namosm_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF) 1250 !----------------------------------------------------------------------- 1251 rn_osm_mle_ce = 0.06 ! magnitude of the MLE (typical value: 0.06 to 0.08) 1252 nn_osm_mle = 0 ! MLE type: =0 standard Fox-Kemper ; =1 new formulation 1253 rn_osm_mle_lf = 5.e+3 ! typical scale of mixed layer front (meters) (case rn_osm_mle=0) 1254 rn_osm_mle_time = 172800. ! time scale for mixing momentum across the mixed layer (seconds) (case rn_osm_mle=0) 1255 rn_osm_mle_lat = 20. ! reference latitude (degrees) of MLE coef. (case rn_mle=1) 1256 rn_osm_mle_rho_c = 0.01 ! delta rho criterion used to calculate MLD for FK 1257 rn_osm_mle_thresh = 0.0005 ! delta b criterion used for FK MLE criterion 1258 rn_osm_mle_tau = 172800. ! time scale for FK-OSM (seconds) (case rn_osm_mle=0) 1259 ln_osm_hmle_limit = .false. ! limit hmle to rn_osm_hmle_limit*hbl 1260 rn_osm_hmle_limit = 1.2 1261 / 1234 1262 !----------------------------------------------------------------------- 1235 1263 &namzdf_mfc ! Mass Flux Convection … … 1374 1402 ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs 1375 1403 ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. 1404 ln_default_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 1376 1405 ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 1377 1406 ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres … … 1389 1418 cn_gridsearchfile ='gridsearch.nc' ! Grid search file name 1390 1419 rn_gridsearchres = 0.5 ! Grid search resolution 1420 rn_default_avglamscl = 0. ! Default E/W diameter of observation footprint (metres/degrees) 1421 rn_default_avgphiscl = 0. ! Default N/S diameter of observation footprint (metres/degrees) 1391 1422 rn_mdtcorr = 1.61 ! MDT correction 1392 1423 rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction … … 1402 1433 rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) 1403 1434 nn_1dint = 0 ! Type of vertical interpolation method 1404 nn_2dint = 0! Default horizontal interpolation method1435 nn_2dint_default = 0 ! Default horizontal interpolation method 1405 1436 nn_2dint_sla = 0 ! Horizontal interpolation method for SLA 1406 1437 nn_2dint_sst = 0 ! Horizontal interpolation method for SST -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/doc/namelists/namobs
r11703 r14062 20 20 ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs 21 21 ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. 22 ln_default_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 22 23 ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 23 24 ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres … … 39 40 rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS 40 41 rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS 42 rn_default_avglamscl = 0. ! Default E/W diameter of observation footprint (metres/degrees) 43 rn_default_avgphiscl = 0. ! Default N/S diameter of observation footprint (metres/degrees) 41 44 rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) 42 45 rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) … … 48 51 rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) 49 52 nn_1dint = 0 ! Type of vertical interpolation method 50 nn_2dint = 0! Default horizontal interpolation method53 nn_2dint_default = 0 ! Default horizontal interpolation method 51 54 nn_2dint_sla = 0 ! Horizontal interpolation method for SLA 52 55 nn_2dint_sst = 0 ! Horizontal interpolation method for SST -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/ICE/iceistate.F90
r14037 r14062 21 21 USE sbc_ice , ONLY : tn_ice, snwice_mass, snwice_mass_b 22 22 USE eosbn2 ! equation of state 23 # if defined key_qco 24 USE domqco ! Variable volume 25 # else 23 26 USE domvvl ! Variable volume 27 # endif 24 28 USE ice ! sea-ice: variables 25 29 USE ice1D ! sea-ice: thermodynamics variables … … 434 438 ssh(:,:,Kbb) = ssh(:,:,Kbb) - snwice_mass(:,:) * r1_rho0 435 439 ! 440 #if defined key_qco 441 IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column 442 #else 436 443 IF( .NOT.ln_linssh ) CALL dom_vvl_zgr( Kbb, Kmm, Kaa ) ! interpolation scale factor, depth and water column 437 ! !!st 438 ! IF( .NOT.ln_linssh ) THEN 439 ! ! 440 ! WHERE( ht_0(:,:) > 0 ) ; z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:) 441 ! ELSEWHERE ; z2d(:,:) = 1._wp ; END WHERE 442 ! ! 443 ! DO jk = 1,jpkm1 ! adjust initial vertical scale factors 444 ! e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:) 445 ! e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 446 ! e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm) 447 ! END DO 448 ! ! 449 ! ! Reconstruction of all vertical scale factors at now and before time-steps 450 ! ! ========================================================================= 451 ! ! Horizontal scale factor interpolations 452 ! ! -------------------------------------- 453 ! CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) 454 ! CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) 455 ! CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 456 ! CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 457 ! CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 458 ! ! Vertical scale factor interpolations 459 ! ! ------------------------------------ 460 ! CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) 461 ! CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 462 ! CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 463 ! CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 464 ! CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 465 ! ! t- and w- points depth 466 ! ! ---------------------- 467 ! !!gm not sure of that.... 468 ! gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) 469 ! gdepw(:,:,1,Kmm) = 0.0_wp 470 ! gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) 471 ! DO jk = 2, jpk 472 ! gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk ,Kmm) 473 ! gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm) 474 ! gde3w(:,:,jk) = gdept(:,:,jk ,Kmm) - ssh (:,:,Kmm) 475 ! END DO 476 ! ENDIF 444 #endif 445 477 446 ENDIF 478 447 -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/NST/agrif_oce_interp.F90
r13286 r14062 28 28 USE agrif_oce 29 29 USE phycst 30 USE dynspg_ts, ONLY: un_adv, vn_adv30 !!! USE dynspg_ts, ONLY: un_adv, vn_adv 31 31 ! 32 32 USE in_out_manager … … 50 50 INTEGER :: bdy_tinterp = 0 51 51 52 !!---------------------------------------------------------------------- 52 !! * Substitutions 53 # include "domzgr_substitute.h90" 53 54 !! NEMO/NST 4.0 , NEMO Consortium (2018) 54 55 !! $Id$ … … 1192 1193 !!---------------------------------------------------------------------- 1193 1194 IF( before ) THEN 1194 IF ( ln_bt_fw ) THEN1195 ! IF ( ln_bt_fw ) THEN 1195 1196 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) 1196 ELSE1197 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)1198 ENDIF1197 ! ELSE 1198 ! ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2) 1199 ! ENDIF 1199 1200 ELSE 1200 1201 zrhot = Agrif_rhot() … … 1228 1229 ! 1229 1230 IF( before ) THEN 1230 IF ( ln_bt_fw ) THEN1231 ! IF ( ln_bt_fw ) THEN 1231 1232 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 1232 ELSE1233 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)1234 ENDIF1233 ! ELSE 1234 ! ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) 1235 ! ENDIF 1235 1236 ELSE 1236 1237 zrhot = Agrif_rhot() -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/NST/agrif_oce_sponge.F90
r13312 r14062 32 32 33 33 !! * Substitutions 34 # include "domzgr_substitute.h90" 34 35 # include "do_loop_substitute.h90" 35 36 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/NST/agrif_oce_update.F90
r13782 r14062 27 27 USE vremap ! Vertical remapping 28 28 USE lbclnk 29 29 #if defined key_qco 30 USE domqco 31 #endif 30 32 IMPLICIT NONE 31 33 PRIVATE … … 34 36 PUBLIC Update_Scales 35 37 38 !! * Substitutions 39 # include "domzgr_substitute.h90" 36 40 !!---------------------------------------------------------------------- 37 41 !! NEMO/NST 4.0 , NEMO Consortium (2018) … … 191 195 END SUBROUTINE Agrif_Update_Tke 192 196 193 194 197 SUBROUTINE Agrif_Update_vvl( ) 195 198 !!--------------------------------------------- … … 201 204 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step() 202 205 ! 206 #if ! defined key_qco 203 207 Agrif_UseSpecialValueInUpdate = .TRUE. 204 208 Agrif_SpecialValueFineGrid = 0. … … 213 217 CALL dom_vvl_update_UVF 214 218 CALL Agrif_ParentGrid_To_ChildGrid() 219 #else 220 CALL Agrif_ChildGrid_To_ParentGrid() 221 CALL Agrif_Update_qco 222 CALL Agrif_ParentGrid_To_ChildGrid() 223 #endif 215 224 ! 216 225 END SUBROUTINE Agrif_Update_vvl 217 226 227 228 #if defined key_qco 229 SUBROUTINE Agrif_Update_qco 230 !!--------------------------------------------- 231 !! *** ROUTINE dom_Update_qco *** 232 !!--------------------------------------------- 233 ! 234 ! Save arrays prior update (needed for asselin correction) 235 r3t(:,:,Krhs_a) = r3t(:,:,Kmm_a) 236 r3u(:,:,Krhs_a) = r3u(:,:,Kmm_a) 237 r3v(:,:,Krhs_a) = r3v(:,:,Kmm_a) 238 239 ! Update r3x arrays from updated ssh 240 CALL dom_qco_zgr( Kbb_a, Kmm_a ) 241 ! 242 END SUBROUTINE Agrif_Update_qco 243 #endif 244 245 246 #if ! defined key_qco 218 247 SUBROUTINE dom_vvl_update_UVF 219 248 !!--------------------------------------------- … … 224 253 REAL(wp):: zcoef 225 254 !!--------------------------------------------- 226 227 255 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', & 228 256 & Agrif_Fixed(), 'Step', Agrif_Nb_Step() … … 290 318 ! 291 319 END SUBROUTINE dom_vvl_update_UVF 320 #endif 292 321 293 322 #if defined key_vertical … … 1336 1365 END SUBROUTINE updateAVM 1337 1366 1367 #if ! defined key_qco 1338 1368 SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before ) 1339 1369 !!--------------------------------------------- … … 1447 1477 ! 1448 1478 END SUBROUTINE updatee3t 1479 #endif 1449 1480 1450 1481 #else -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/NST/agrif_user.F90
r14037 r14062 288 288 CALL Agrif_Init_Variable(sshini_id, procname=agrif_initssh) 289 289 CALL lbc_lnk( 'Agrif_Init_Domain', ssh(:,:,Kbb), 'T', 1. ) 290 #if ! defined key_qco 290 291 DO jk = 1, jpk 291 292 e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) & … … 293 294 & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 294 295 END DO 296 #endif 295 297 ENDIF 296 298 -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DIA/diawri.F90
r14037 r14062 19 19 !! 3.7 ! 2014-01 (G. Madec) remove eddy induced velocity from no-IOM output 20 20 !! ! change name of output variables in dia_wri_state 21 !! 4.0 ! 2020-10 (A. Nasser, S. Techene) add diagnostic for SWE 21 22 !!---------------------------------------------------------------------- 22 23 … … 46 47 USE zdfdrg ! ocean vertical physics: top/bottom friction 47 48 USE zdfmxl ! mixed layer 49 USE zdfosm ! mixed layer 48 50 ! 49 51 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 118 120 INTEGER :: ji, jj, jk ! dummy loop indices 119 121 INTEGER :: ikbot ! local integer 120 REAL(wp):: ze3121 122 REAL(wp):: zztmp , zztmpx ! local scalar 122 123 REAL(wp):: zztmp2, zztmpy ! - - 124 REAL(wp):: ze3 123 125 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 124 126 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace … … 137 139 CALL iom_put("e3u_0", e3u_0(:,:,:) ) 138 140 CALL iom_put("e3v_0", e3v_0(:,:,:) ) 141 CALL iom_put("e3f_0", e3f_0(:,:,:) ) 139 142 ! 140 143 IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t … … 163 166 CALL iom_put( "e3w" , z3d(:,:,:) ) 164 167 ENDIF 168 IF ( iom_use("e3f") ) THEN ! time-varying e3f caution here at Kaa 169 DO jk = 1, jpk 170 z3d(:,:,jk) = e3f(:,:,jk) 171 END DO 172 CALL iom_put( "e3f" , z3d(:,:,:) ) 173 ENDIF 165 174 166 175 IF( ll_wd ) THEN ! sea surface height (brought back to the reference used for wetting and drying) 167 CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)* tmask(:,:,1) )176 CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*ssmask(:,:) ) 168 177 ELSE 169 178 CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height 170 179 ENDIF 171 180 172 IF( iom_use("wetdep") ) & ! wet depth 173 CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) ) 181 IF( iom_use("wetdep") ) CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) ) ! wet depth 182 183 #if defined key_qco 184 IF( iom_use("ht") ) CALL iom_put( "ht" , ht(:,:) ) ! water column at t-point 185 IF( iom_use("hu") ) CALL iom_put( "hu" , hu(:,:,Kmm) ) ! water column at u-point 186 IF( iom_use("hv") ) CALL iom_put( "hv" , hv(:,:,Kmm) ) ! water column at v-point 187 IF( iom_use("hf") ) CALL iom_put( "hf" , hf_0(:,:)*( 1._wp + r3f(:,:) ) ) ! water column at f-point (caution here at Naa) 188 #endif 174 189 175 190 CALL iom_put( "toce", ts(:,:,:,jp_tem,Kmm) ) ! 3D temperature … … 325 340 ENDIF 326 341 ! 342 IF ( iom_use("sKE") ) THEN ! surface kinetic energy at T point 343 z2d(:,:) = 0._wp 344 DO_2D( 0, 0, 0, 0 ) 345 z2d(ji,jj) = 0.25_wp * ( uu(ji ,jj,1,Kmm) * uu(ji ,jj,1,Kmm) * e1e2u(ji ,jj) * e3u(ji ,jj,1,Kmm) & 346 & + uu(ji-1,jj,1,Kmm) * uu(ji-1,jj,1,Kmm) * e1e2u(ji-1,jj) * e3u(ji-1,jj,1,Kmm) & 347 & + vv(ji,jj ,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji,jj ) * e3v(ji,jj ,1,Kmm) & 348 & + vv(ji,jj-1,1,Kmm) * vv(ji,jj-1,1,Kmm) * e1e2v(ji,jj-1) * e3v(ji,jj-1,1,Kmm) ) & 349 & * r1_e1e2t(ji,jj) / e3t(ji,jj,1,Kmm) * ssmask(ji,jj) 350 END_2D 351 CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) 352 IF ( iom_use("sKE" ) ) CALL iom_put( "sKE" , z2d ) 353 ENDIF 354 ! 355 IF ( iom_use("sKEf") ) THEN ! surface kinetic energy at F point 356 z2d(:,:) = 0._wp ! CAUTION : only valid in SWE, not with bathymetry 357 DO_2D( 0, 0, 0, 0 ) 358 z2d(ji,jj) = 0.25_wp * ( uu(ji,jj ,1,Kmm) * uu(ji,jj ,1,Kmm) * e1e2u(ji,jj ) * e3u(ji,jj ,1,Kmm) & 359 & + uu(ji,jj+1,1,Kmm) * uu(ji,jj+1,1,Kmm) * e1e2u(ji,jj+1) * e3u(ji,jj+1,1,Kmm) & 360 & + vv(ji ,jj,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji ,jj) * e3v(ji ,jj,1,Kmm) & 361 & + vv(ji+1,jj,1,Kmm) * vv(ji+1,jj,1,Kmm) * e1e2v(ji+1,jj) * e3v(ji+1,jj,1,Kmm) ) & 362 & * r1_e1e2f(ji,jj) / e3f(ji,jj,1) * ssfmask(ji,jj) 363 END_2D 364 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 365 CALL iom_put( "sKEf", z2d ) 366 ENDIF 367 ! 327 368 CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence 328 369 … … 424 465 425 466 IF (ln_dia25h) CALL dia_25h( kt, Kmm ) ! 25h averaging 467 468 ! Output of vorticity terms 469 IF ( iom_use("relvor") .OR. iom_use("plavor") .OR. & 470 & iom_use("relpotvor") .OR. iom_use("abspotvor") .OR. & 471 & iom_use("Ens") ) THEN 472 ! 473 z2d(:,:) = 0._wp 474 ze3 = 0._wp 475 DO_2D( 1, 0, 1, 0 ) 476 z2d(ji,jj) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,1,Kmm) - e2v(ji,jj) * vv(ji,jj,1,Kmm) & 477 & - e1u(ji ,jj+1) * uu(ji ,jj+1,1,Kmm) + e1u(ji,jj) * uu(ji,jj,1,Kmm) ) * r1_e1e2f(ji,jj) 478 END_2D 479 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 480 CALL iom_put( "relvor", z2d ) ! relative vorticity ( zeta ) 481 ! 482 CALL iom_put( "plavor", ff_f ) ! planetary vorticity ( f ) 483 ! 484 DO_2D( 1, 0, 1, 0 ) 485 ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) & 486 & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj) 487 IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 488 ELSE ; ze3 = 0._wp 489 ENDIF 490 z2d(ji,jj) = ze3 * z2d(ji,jj) 491 END_2D 492 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 493 CALL iom_put( "relpotvor", z2d ) ! relative potential vorticity (zeta/h) 494 ! 495 DO_2D( 1, 0, 1, 0 ) 496 ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) & 497 & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj) 498 IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 499 ELSE ; ze3 = 0._wp 500 ENDIF 501 z2d(ji,jj) = ze3 * ff_f(ji,jj) + z2d(ji,jj) 502 END_2D 503 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 504 CALL iom_put( "abspotvor", z2d ) ! absolute potential vorticity ( q ) 505 ! 506 DO_2D( 1, 0, 1, 0 ) 507 z2d(ji,jj) = 0.5_wp * z2d(ji,jj) * z2d(ji,jj) 508 END_2D 509 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 510 CALL iom_put( "Ens", z2d ) ! potential enstrophy ( 1/2*q2 ) 511 ! 512 ENDIF 426 513 427 514 IF( ln_timing ) CALL timing_stop('dia_wri') … … 997 1084 !! 998 1085 INTEGER :: inum, jk 999 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept ! 3D workspace !!st patch to usesubstitution1086 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept ! 3D workspace for qco substitution 1000 1087 !!---------------------------------------------------------------------- 1001 1088 ! … … 1076 1163 CALL iom_rstput ( 0, 0, inum, "qz1_abl", tq_abl(:,:,2,nt_a,2) ) ! now first level humidity 1077 1164 ENDIF 1165 IF( ln_zdfosm ) THEN 1166 CALL iom_rstput( 0, 0, inum, 'hbl', hbl*tmask(:,:,1) ) ! now boundary-layer depth 1167 CALL iom_rstput( 0, 0, inum, 'hml', hml*tmask(:,:,1) ) ! now mixed-layer depth 1168 CALL iom_rstput( 0, 0, inum, 'avt_k', avt_k*wmask ) ! w-level diffusion 1169 CALL iom_rstput( 0, 0, inum, 'avm_k', avm_k*wmask ) ! now w-level viscosity 1170 CALL iom_rstput( 0, 0, inum, 'ghamt', ghamt*wmask ) ! non-local t forcing 1171 CALL iom_rstput( 0, 0, inum, 'ghams', ghams*wmask ) ! non-local s forcing 1172 CALL iom_rstput( 0, 0, inum, 'ghamu', ghamu*umask ) ! non-local u forcing 1173 CALL iom_rstput( 0, 0, inum, 'ghamv', ghamv*vmask ) ! non-local v forcing 1174 IF( ln_osm_mle ) THEN 1175 CALL iom_rstput( 0, 0, inum, 'hmle', hmle*tmask(:,:,1) ) ! now transition-layer depth 1176 END IF 1177 ENDIF 1078 1178 ! 1079 1179 CALL iom_close( inum ) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/dom_oce.F90
r14037 r14062 131 131 ! 132 132 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point 133 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , e2_e1u, r1_e1e2u!: associated metrics at u-point134 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , e1_e2v, r1_e1e2v!: associated metrics at v-point133 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point 134 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point 135 135 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point 136 136 ! … … 162 162 163 163 ! ! reference depths of cells 164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m]165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m]166 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m]164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m] 165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m] 166 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m] 167 167 ! ! time-dependent depths of cells 168 168 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw … … 205 205 206 206 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts 207 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts 208 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts 209 207 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts 208 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WU- and WV-pts 209 #if defined key_qco 210 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: fe3mask !: land/ocean mask at F-pts for qco 211 #endif 210 212 !!---------------------------------------------------------------------- 211 213 !! calendar variables … … 306 308 & e3w_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , STAT=ierr(ii) ) 307 309 ! 308 #if ! defined key_qco 310 #if defined key_qco 311 ii = ii+1 312 ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , & 313 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) 314 #else 309 315 ii = ii+1 310 316 ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , & … … 313 319 ! 314 320 ii = ii+1 315 ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , &316 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) )317 !318 ii = ii+1319 321 ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , hf_0(jpi,jpj) , & 320 322 & r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) , r1_hv_0(jpi,jpj), r1_hf_0(jpi,jpj) , STAT=ierr(ii) ) … … 323 325 ii = ii+1 324 326 ALLOCATE( ht (jpi,jpj) , hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , & 325 & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) )326 #else327 ii = ii+1328 ALLOCATE( hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , &329 327 & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) ) 330 328 #endif … … 350 348 ii = ii+1 351 349 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 350 #if defined key_qco 351 ! 352 ii = ii+1 353 ALLOCATE( fe3mask(jpi,jpj,jpk) , STAT=ierr(ii) ) 354 #endif 352 355 ! 353 356 dom_oce_alloc = MAXVAL(ierr) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/domain.F90
r14037 r14062 15 15 !! 3.7 ! 2015-11 (G. Madec, A. Coward) time varying zgr by default 16 16 !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface 17 !! 4. x ! 2020-02 (G. Madec, S. Techene)introduce ssh to h0 ratio17 !! 4.1 ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio 18 18 !!---------------------------------------------------------------------- 19 19 … … 28 28 USE oce ! ocean variables 29 29 USE dom_oce ! domain: ocean 30 #if defined key_qco 31 USE domqco ! quasi-eulerian 32 #else 33 USE domvvl ! variable volume 34 #endif 35 USE sshwzv , ONLY : ssh_init_rst ! set initial ssh 30 36 USE sbc_oce ! surface boundary condition: ocean 31 37 USE trc_oce ! shared ocean & passive tracers variab … … 35 41 USE dommsk ! domain: set the mask system 36 42 USE domwri ! domain: write the meshmask file 37 #if ! defined key_qco38 USE domvvl ! variable volume39 #else40 USE domqco ! variable volume41 #endif42 43 USE c1d ! 1D configuration 43 44 USE dyncor_c1d ! 1D configuration: Coriolis term (cor_c1d routine) 44 USE wet_dry , ONLY : ll_wd45 USE closea , ONLY : dom_clo ! closed seas45 USE wet_dry , ONLY : ll_wd ! wet & drying flag 46 USE closea , ONLY : dom_clo ! closed seas routine 46 47 ! 47 48 USE prtctl ! Print control (prt_ctl_info routine) … … 50 51 USE lbclnk ! ocean lateral boundary condition (or mpp link) 51 52 USE lib_mpp ! distributed memory computing library 53 USE restart ! only for lrst_oce 52 54 53 55 IMPLICIT NONE … … 58 60 PUBLIC dom_tile ! called by step.F90 59 61 62 !! * Substitutions 63 # include "do_loop_substitute.h90" 60 64 !!------------------------------------------------------------------------- 61 65 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 84 88 INTEGER :: ji, jj, jk, jt ! dummy loop indices 85 89 INTEGER :: iconf = 0 ! local integers 90 REAL(wp):: zrdt 86 91 CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" 87 92 INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level … … 121 126 WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg 122 127 ENDIF 123 nn_wxios = 0 124 ln_xios_read = .FALSE. 128 125 129 ! 126 130 ! !== Reference coordinate system ==! … … 143 147 hv_0(:,:) = 0._wp 144 148 hf_0(:,:) = 0._wp 145 DO jk = 1, jpk 149 DO jk = 1, jpkm1 146 150 ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 147 151 hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) 148 152 hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) 149 hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,jk) * fmask(:,:,jk)150 153 END DO 154 ! 155 DO jk = 1, jpkm1 156 hf_0(1:jpim1,:) = hf_0(1:jpim1,:) + e3f_0(1:jpim1,:,jk)*vmask(1:jpim1,:,jk)*vmask(2:jpi,:,jk) 157 END DO 158 CALL lbc_lnk('domain', hf_0, 'F', 1._wp) 159 ! 160 IF( lk_SWE ) THEN ! SWE case redefine hf_0 161 hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,1) * ssfmask(:,:) 162 ENDIF 151 163 ! 152 164 r1_ht_0(:,:) = ssmask (:,:) / ( ht_0(:,:) + 1._wp - ssmask (:,:) ) … … 154 166 r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) 155 167 r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp - ssfmask(:,:) ) 156 168 ! 169 IF( ll_wd ) THEN ! wet and drying (check ht_0 >= 0) 170 DO_2D( 1, 1, 1, 1 ) 171 IF( ht_0(ji,jj) < 0._wp .AND. ssmask(ji,jj) == 1._wp ) THEN 172 CALL ctl_stop( 'ssh_init_rst : ht_0 must be positive at potentially wet points' ) 173 ENDIF 174 END_2D 175 ENDIF 176 ! 177 ! !== initialisation of time varying coordinate ==! 178 ! 179 ! != ssh initialization 180 IF( .NOT.l_offline .AND. .NOT.l_SAS ) THEN 181 CALL ssh_init_rst( Kbb, Kmm, Kaa ) 182 ELSE 183 ssh(:,:,:) = 0._wp 184 ENDIF 157 185 ! 158 186 #if defined key_qco 159 ! !== initialisation of time varying coordinate ==!Quasi-Euerian coordinate case187 ! != Quasi-Euerian coordinate case 160 188 ! 161 189 IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa ) 162 !163 IF( ln_linssh ) CALL ctl_stop('STOP','domain: key_qco and ln_linssh = T are incompatible')164 !165 190 #else 166 ! !== time varying part of coordinate system ==! 167 ! 168 IF( ln_linssh ) THEN != Fix in time : set to the reference one for all 191 ! 192 IF( ln_linssh ) THEN != Fix in time : set to the reference one for all 169 193 ! 170 194 DO jt = 1, jpt ! depth of t- and w-grid-points … … 175 199 ! 176 200 DO jt = 1, jpt ! vertical scale factors 177 e3t (:,:,:,jt) = e3t_0(:,:,:)178 e3u (:,:,:,jt) = e3u_0(:,:,:)179 e3v (:,:,:,jt) = e3v_0(:,:,:)180 e3w (:,:,:,jt) = e3w_0(:,:,:)201 e3t (:,:,:,jt) = e3t_0(:,:,:) 202 e3u (:,:,:,jt) = e3u_0(:,:,:) 203 e3v (:,:,:,jt) = e3v_0(:,:,:) 204 e3w (:,:,:,jt) = e3w_0(:,:,:) 181 205 e3uw(:,:,:,jt) = e3uw_0(:,:,:) 182 206 e3vw(:,:,:,jt) = e3vw_0(:,:,:) 183 207 END DO 184 e3f (:,:,:) = e3f_0(:,:,:)208 e3f (:,:,:) = e3f_0(:,:,:) 185 209 ! 186 210 DO jt = 1, jpt ! water column thickness and its inverse 187 hu(:,:,jt)= hu_0(:,:)188 hv(:,:,jt)= hv_0(:,:)211 hu(:,:,jt) = hu_0(:,:) 212 hv(:,:,jt) = hv_0(:,:) 189 213 r1_hu(:,:,jt) = r1_hu_0(:,:) 190 214 r1_hv(:,:,jt) = r1_hv_0(:,:) 191 215 END DO 192 ht(:,:) = ht_0(:,:)193 ! 194 ELSE != time varying : initialize before/now/after variables216 ht (:,:) = ht_0(:,:) 217 ! 218 ELSE != Time varying : initialize before/now/after variables 195 219 ! 196 220 IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) … … 373 397 USE ioipsl 374 398 !! 375 INTEGER :: ios ! Local integer 399 INTEGER :: ios ! Local integer 400 REAL(wp):: zrdt 401 !!---------------------------------------------------------------------- 376 402 ! 377 403 NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, & … … 393 419 ENDIF 394 420 ! 421 ! !=======================! 422 ! !== namelist namdom ==! 423 ! !=======================! 424 ! 425 READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 426 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) 427 READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 428 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 429 IF(lwm) WRITE( numond, namdom ) 430 ! 431 #if defined key_agrif 432 IF( .NOT. Agrif_Root() ) THEN ! AGRIF child, subdivide the Parent timestep 433 rn_Dt = Agrif_Parent (rn_Dt ) / Agrif_Rhot() 434 ENDIF 435 #endif 436 ! 437 IF(lwp) THEN 438 WRITE(numout,*) 439 WRITE(numout,*) ' Namelist : namdom --- space & time domain' 440 WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh 441 WRITE(numout,*) ' create mesh/mask file ln_meshmask = ', ln_meshmask 442 WRITE(numout,*) ' ocean time step rn_Dt = ', rn_Dt 443 WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp 444 WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs 445 ENDIF 446 ! 447 ! set current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 448 rDt = 2._wp * rn_Dt 449 r1_Dt = 1._wp / rDt 450 ! 451 IF( l_SAS .AND. .NOT.ln_linssh ) THEN 452 CALL ctl_warn( 'SAS requires linear ssh : force ln_linssh = T' ) 453 ln_linssh = .TRUE. 454 ENDIF 455 ! 456 #if defined key_qco 457 IF( ln_linssh ) CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh = T are incompatible' ) 458 #endif 459 ! 460 ! !=======================! 461 ! !== namelist namrun ==! 462 ! !=======================! 395 463 ! 396 464 READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) … … 452 520 nleapy = nn_leapy 453 521 ninist = nn_istate 522 ! 523 ! !== Set parameters for restart reading using xIOS ==! 524 ! 525 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 526 lrxios = ln_xios_read .AND. ln_rstart 527 IF( nn_wxios > 0 ) lwxios = .TRUE. !* set output file type for XIOS based on NEMO namelist 528 nxioso = nn_wxios 529 ENDIF 530 ! !== Check consistency between ln_rstart and ln_1st_euler ==! (i.e. set l_1st_euler) 454 531 l_1st_euler = ln_1st_euler 455 IF( .NOT. l_1st_euler .AND. .NOT. ln_rstart ) THEN 532 ! 533 IF( ln_rstart ) THEN !* Restart case 534 ! 535 IF(lwp) WRITE(numout,*) 536 IF(lwp) WRITE(numout,*) ' open the restart file' 537 CALL rst_read_open !- Open the restart file 538 ! 539 IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN !- Check time-step consistency and force Euler restart if changed 540 CALL iom_get( numror, 'rdt', zrdt ) 541 IF( zrdt /= rn_Dt ) THEN 542 IF(lwp) WRITE( numout,*) 543 IF(lwp) WRITE( numout,*) ' rn_Dt = ', rn_Dt,' not equal to the READ one rdt = ', zrdt 544 IF(lwp) WRITE( numout,*) 545 IF(lwp) WRITE( numout,*) ' ==>>> forced euler first time-step' 546 l_1st_euler = .TRUE. 547 ENDIF 548 ENDIF 549 ! 550 IF( .NOT.l_SAS .AND. iom_varid( numror, 'sshb', ldstop = .FALSE. ) <= 0 ) THEN !- Check absence of one of the Kbb field (here sshb) 551 ! ! (any Kbb field is missing ==> all Kbb fields are missing) 552 IF( .NOT.l_1st_euler ) THEN 553 CALL ctl_warn('dom_nam : ssh at Kbb not found in restart files ', & 554 & 'l_1st_euler forced to .true. and ' , & 555 & 'ssh(Kbb) = ssh(Kmm) ' ) 556 l_1st_euler = .TRUE. 557 ENDIF 558 ENDIF 559 ELSEIF( .NOT.l_1st_euler ) THEN !* Initialization case 456 560 IF(lwp) WRITE(numout,*) 457 561 IF(lwp) WRITE(numout,*)' ==>>> Start from rest (ln_rstart=F)' 458 562 IF(lwp) WRITE(numout,*)' an Euler initial time step is used : l_1st_euler is forced to .true. ' 459 l_1st_euler = .true. 460 ENDIF 461 ! ! control of output frequency 462 IF( .NOT. ln_rst_list ) THEN ! we use nn_stock 563 l_1st_euler = .TRUE. 564 ENDIF 565 ! 566 ! !== control of output frequency ==! 567 ! 568 IF( .NOT. ln_rst_list ) THEN ! we use nn_stock 463 569 IF( nn_stock == -1 ) CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) 464 570 IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN … … 479 585 IF( Agrif_Root() ) THEN 480 586 IF(lwp) WRITE(numout,*) 481 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL587 SELECT CASE ( nleapy ) !== Choose calendar for IOIPSL ==! 482 588 CASE ( 1 ) 483 589 CALL ioconf_calendar('gregorian') … … 491 597 END SELECT 492 598 ENDIF 493 494 READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 495 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) 496 READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 497 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 498 IF(lwm) WRITE( numond, namdom ) 499 ! 500 #if defined key_agrif 501 IF( .NOT. Agrif_Root() ) THEN 502 rn_Dt = Agrif_Parent(rn_Dt) / Agrif_Rhot() 503 ENDIF 504 #endif 505 ! 506 IF(lwp) THEN 507 WRITE(numout,*) 508 WRITE(numout,*) ' Namelist : namdom --- space & time domain' 509 WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh 510 WRITE(numout,*) ' create mesh/mask file ln_meshmask = ', ln_meshmask 511 WRITE(numout,*) ' ocean time step rn_Dt = ', rn_Dt 512 WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp 513 WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs 514 ENDIF 515 ! 516 !! Initialise current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 517 rDt = 2._wp * rn_Dt 518 r1_Dt = 1._wp / rDt 519 599 ! 600 ! !========================! 601 ! !== namelist namtile ==! 602 ! !========================! 603 ! 520 604 READ ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) 521 605 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtile in reference namelist' ) … … 537 621 ENDIF 538 622 ENDIF 539 540 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 541 lrxios = ln_xios_read.AND.ln_rstart 542 !set output file type for XIOS based on NEMO namelist 543 IF (nn_wxios > 0) lwxios = .TRUE. 544 nxioso = nn_wxios 545 ENDIF 546 623 ! 547 624 #if defined key_netcdf4 548 ! ! NetCDF 4 case ("key_netcdf4" defined) 625 ! !=======================! 626 ! !== namelist namnc4 ==! NetCDF 4 case ("key_netcdf4" defined) 627 ! !=======================! 628 ! 549 629 READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 550 630 907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) … … 555 635 IF(lwp) THEN ! control print 556 636 WRITE(numout,*) 557 WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters '637 WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters ("key_netcdf4" defined)' 558 638 WRITE(numout,*) ' number of chunks in i-dimension nn_nchunks_i = ', nn_nchunks_i 559 639 WRITE(numout,*) ' number of chunks in j-dimension nn_nchunks_j = ', nn_nchunks_j … … 618 698 SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 619 699 !!---------------------------------------------------------------------- 620 !! *** ROUTINE dom _nam***700 !! *** ROUTINE domain_cfg *** 621 701 !! 622 702 !! ** Purpose : read the domain size in domain configuration file -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/dommsk.F90
r14037 r14062 181 181 ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 ) 182 182 ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 ) 183 IF( lk_SWE ) THEN ! Shallow Water Eq. case : redefine ssfmask 184 DO_2D( 0,0 , 0,0 ) 185 ssfmask(ji,jj) = MAX( ssmask(ji,jj+1), ssmask(ji+1,jj+1), & 186 & ssmask(ji,jj ), ssmask(ji+1,jj ) ) 187 END_2D 188 CALL lbc_lnk( 'dommsk', ssfmask, 'F', 1.0_wp ) 189 ENDIF 190 #if defined key_qco 191 fe3mask(:,:,:) = fmask(:,:,:) 192 #endif 183 193 184 194 ! Interior domain mask (used for global sum) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/domqco.F90
r14037 r14062 8 8 !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates 9 9 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 10 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping11 !! 4.x ! 2020-02 (G. Madec, S. Techene) pure z* (quasi-eulerian) coordinate12 !!---------------------------------------------------------------------- 13 14 !!---------------------------------------------------------------------- 15 !! dom_q e_init: define initial vertical scale factors, depths and column thickness16 !! dom_q e_r3c : Compute ssh/h_0 ratioat t-, u-, v-, and optionally f-points17 !! qe_rst_read : read/write restart file18 !! dom_qe_ctl: Check the vvl options10 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) add time level indices for prognostic variables 11 !! - ! 2020-02 (S. Techene, G. Madec) quasi-eulerian coordinate (z* or s*) 12 !!---------------------------------------------------------------------- 13 14 !!---------------------------------------------------------------------- 15 !! dom_qco_init : define initial vertical scale factors, depths and column thickness 16 !! dom_qco_zgr : Set ssh/h_0 ratio at t 17 !! dom_qco_r3c : Compute ssh/h_0 ratio at t-, u-, v-, and optionally f-points 18 !! qco_ctl : Check the vvl options 19 19 !!---------------------------------------------------------------------- 20 20 USE oce ! ocean dynamics and tracers … … 55 55 LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints 56 56 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td ! thickness diffusion transport58 59 57 !! * Substitutions 60 58 # include "do_loop_substitute.h90" … … 79 77 !! 80 78 !!---------------------------------------------------------------------- 81 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 79 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! time level indices 80 !!---------------------------------------------------------------------- 82 81 ! 83 82 IF(lwp) WRITE(numout,*) … … 85 84 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 86 85 ! 87 CALL dom_qco_ctl ! choose vertical coordinate (z_star, z_tilde or layer) 88 ! 89 ! ! Read or initialize e3t_(b/n), tilde_e3t_(b/n) and hdiv_lf 90 CALL qe_rst_read( nit000, Kbb, Kmm ) 91 ! 92 CALL dom_qco_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column 86 CALL qco_ctl ! choose vertical coordinate (z_star, z_tilde or layer) 87 ! 88 CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column 89 ! 90 #if defined key_agrif 91 ! We need to define r3[tuv](Kaa) for AGRIF initialisation (should not be a 92 ! problem for the restartability...) 93 r3t(:,:,Kaa) = r3t(:,:,Kmm) 94 r3u(:,:,Kaa) = r3u(:,:,Kmm) 95 r3v(:,:,Kaa) = r3v(:,:,Kmm) 96 #endif 93 97 ! 94 98 END SUBROUTINE dom_qco_init 95 99 96 100 97 SUBROUTINE dom_qco_zgr( Kbb, Kmm, Kaa)101 SUBROUTINE dom_qco_zgr( Kbb, Kmm ) 98 102 !!---------------------------------------------------------------------- 99 103 !! *** ROUTINE dom_qco_init *** 100 104 !! 101 !! ** Purpose : Initialization of all ssh. to h._0 ratio 102 !! 103 !! ** Method : - interpolate scale factors 104 !! 105 !! ** Action : - r3(t/u/v)_b 106 !! - r3(t/u/v/f)_n 107 !! 108 !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling. 109 !!---------------------------------------------------------------------- 110 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 105 !! ** Purpose : Initialization of all r3. = ssh./h._0 ratios 106 !! 107 !! ** Method : Call domqco using Kbb and Kmm 108 !! NB: dom_qco_zgr is called by dom_qco_init it uses ssh from ssh_init 109 !! 110 !! ** Action : - r3(t/u/v)(Kbb) 111 !! - r3(t/u/v/f)(Kmm) 112 !!---------------------------------------------------------------------- 113 INTEGER, INTENT(in) :: Kbb, Kmm ! time level indices 111 114 !!---------------------------------------------------------------------- 112 115 ! 113 116 ! !== Set of all other vertical scale factors ==! (now and before) 114 117 ! ! Horizontal interpolation of e3t 115 CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) )118 CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) ) 116 119 CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm), r3f(:,:) ) 117 120 ! … … 143 146 ! !== ratio at u-,v-point ==! 144 147 ! 145 IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) 148 !!st IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) 149 #if ! defined key_qcoTest_FluxForm 150 ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 146 151 DO_2D( 0, 0, 0, 0 ) 147 152 pr3u(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) & … … 150 155 & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj) 151 156 END_2D 152 ELSE !- Flux Form (simple averaging) 157 !!st ELSE !- Flux Form (simple averaging) 158 #else 153 159 DO_2D( 0, 0, 0, 0 ) 154 pr3u(ji,jj) = 0.5_wp * ( pssh(ji ,jj) + pssh(ji+1,jj) ) * r1_hu_0(ji,jj)155 pr3v(ji,jj) = 0.5_wp * ( pssh(ji,jj ) + pssh(ji,jj+1) ) * r1_hv_0(ji,jj)160 pr3u(ji,jj) = 0.5_wp * ( pssh(ji,jj) + pssh(ji+1,jj ) ) * r1_hu_0(ji,jj) 161 pr3v(ji,jj) = 0.5_wp * ( pssh(ji,jj) + pssh(ji ,jj+1) ) * r1_hv_0(ji,jj) 156 162 END_2D 157 ENDIF 163 !!st ENDIF 164 #endif 158 165 ! 159 166 IF( .NOT.PRESENT( pr3f ) ) THEN !- lbc on ratio at u-, v-points only … … 163 170 ELSE !== ratio at f-point ==! 164 171 ! 165 IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) 166 DO_2D( 1, 0, 1, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 172 !!st IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) 173 #if ! defined key_qcoTest_FluxForm 174 ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 175 176 DO_2D( 0, 0, 0, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 167 177 pr3f(ji,jj) = 0.25_wp * ( e1e2t(ji ,jj ) * pssh(ji ,jj ) & 168 178 & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) & … … 170 180 & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) 171 181 END_2D 172 ELSE !- Flux Form (simple averaging) 173 DO_2D( 1, 0, 1, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 174 pr3f(ji,jj) = 0.25_wp * ( pssh(ji ,jj ) + pssh(ji+1,jj ) & 175 & + pssh(ji ,jj+1) + pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) 182 !!st ELSE !- Flux Form (simple averaging) 183 #else 184 DO_2D( 0, 0, 0, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 185 pr3f(ji,jj) = 0.25_wp * ( pssh(ji,jj ) + pssh(ji+1,jj ) & 186 & + pssh(ji,jj+1) + pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) 176 187 END_2D 177 ENDIF 188 !!st ENDIF 189 #endif 178 190 ! ! lbc on ratio at u-,v-,f-points 179 191 CALL lbc_lnk_multi( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp, pr3f, 'F', 1._wp ) … … 184 196 185 197 186 SUBROUTINE q e_rst_read( kt, Kbb, Kmm )198 SUBROUTINE qco_ctl 187 199 !!--------------------------------------------------------------------- 188 !! *** ROUTINE qe_rst_read *** 189 !! 190 !! ** Purpose : Read ssh in restart file 191 !! 192 !! ** Method : use of IOM library 193 !! if the restart does not contain ssh, 194 !! it is set to the _0 values. 195 !!---------------------------------------------------------------------- 196 INTEGER , INTENT(in) :: kt ! ocean time-step 197 INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices 198 ! 199 INTEGER :: ji, jj, jk 200 INTEGER :: id1, id2 ! local integers 201 !!---------------------------------------------------------------------- 202 ! 203 IF( ln_rstart ) THEN !* Read the restart file 204 CALL rst_read_open ! open the restart file if necessary 205 ! 206 id1 = iom_varid( numror, 'sshb', ldstop = .FALSE. ) 207 id2 = iom_varid( numror, 'sshn', ldstop = .FALSE. ) 208 ! 209 ! ! --------- ! 210 ! ! all cases ! 211 ! ! --------- ! 212 ! 213 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 214 CALL iom_get( numror, jpdom_auto, 'sshb' , ssh(:,:,Kbb) ) 215 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 216 ! needed to restart if land processor not computed 217 IF(lwp) write(numout,*) 'qe_rst_read : ssh(:,:,Kbb) and ssh(:,:,Kmm) found in restart files' 218 WHERE ( ssmask(:,:) == 0.0_wp ) !!gm/st ==> sm should not be necessary on ssh when it was required on e3 219 ssh(:,:,Kmm) = 0._wp 220 ssh(:,:,Kbb) = 0._wp 221 END WHERE 222 IF( l_1st_euler ) THEN 223 ssh(:,:,Kbb) = ssh(:,:,Kmm) 224 ENDIF 225 ELSE IF( id1 > 0 ) THEN 226 IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kmm) not found in restart files' 227 IF(lwp) write(numout,*) 'sshn set equal to sshb.' 228 IF(lwp) write(numout,*) 'neuler is forced to 0' 229 CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 230 ssh(:,:,Kmm) = ssh(:,:,Kbb) 231 l_1st_euler = .TRUE. 232 ELSE IF( id2 > 0 ) THEN 233 IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kbb) not found in restart files' 234 IF(lwp) write(numout,*) 'sshb set equal to sshn.' 235 IF(lwp) write(numout,*) 'neuler is forced to 0' 236 CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm) ) 237 ssh(:,:,Kbb) = ssh(:,:,Kmm) 238 l_1st_euler = .TRUE. 239 ELSE 240 IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kmm) not found in restart file' 241 IF(lwp) write(numout,*) 'ssh_b and ssh_n set to zero' 242 IF(lwp) write(numout,*) 'neuler is forced to 0' 243 ssh(:,:,:) = 0._wp 244 l_1st_euler = .TRUE. 245 ENDIF 246 ! 247 ELSE !* Initialize at "rest" 248 ! 249 IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential 250 ! 251 IF( cn_cfg == 'wad' ) THEN ! Wetting and drying test case 252 CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 253 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 254 ssh(:,: ,Kmm) = ssh(:,: ,Kbb) 255 uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) 256 vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) 257 ELSE ! if not test case 258 ssh(:,:,Kmm) = -ssh_ref 259 ssh(:,:,Kbb) = -ssh_ref 260 ! 261 DO_2D( 1, 1, 1, 1 ) 262 IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth 263 ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) ) 264 ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) ) 265 ENDIF 266 END_2D 267 ENDIF 268 269 DO ji = 1, jpi 270 DO jj = 1, jpj 271 IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN 272 CALL ctl_stop( 'qe_rst_read: ht_0 must be positive at potentially wet points' ) 273 ENDIF 274 END DO 275 END DO 276 ! 277 ELSE 278 ! 279 ! Just to read set ssh in fact, called latter once vertical grid 280 ! is set up: 281 ! CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 282 ! ! 283 ssh(:,:,:) = 0._wp 284 ! 285 ENDIF ! end of ll_wd edits 286 ! 287 ENDIF 288 ! 289 END SUBROUTINE qe_rst_read 290 291 292 SUBROUTINE dom_qco_ctl 293 !!--------------------------------------------------------------------- 294 !! *** ROUTINE dom_qco_ctl *** 200 !! *** ROUTINE qco_ctl *** 295 201 !! 296 202 !! ** Purpose : Control the consistency between namelist options … … 312 218 IF(lwp) THEN ! Namelist print 313 219 WRITE(numout,*) 314 WRITE(numout,*) ' dom_qco_ctl : choice/control of the variable vertical coordinate'315 WRITE(numout,*) '~~~~~~~~ ~~~'220 WRITE(numout,*) 'qco_ctl : choice/control of the variable vertical coordinate' 221 WRITE(numout,*) '~~~~~~~~' 316 222 WRITE(numout,*) ' Namelist nam_vvl : chose a vertical coordinate' 317 223 WRITE(numout,*) ' zstar ln_vvl_zstar = ', ln_vvl_zstar … … 357 263 #endif 358 264 ! 359 END SUBROUTINE dom_qco_ctl265 END SUBROUTINE qco_ctl 360 266 361 267 !!====================================================================== -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/domvvl.F90
r14037 r14062 9 9 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 10 10 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping 11 !! 4.x !2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio11 !! - ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio 12 12 !!---------------------------------------------------------------------- 13 13 … … 766 766 !! ** Purpose : Read or write VVL file in restart file 767 767 !! 768 !! ** Method : use of IOM library 769 !! if the restart does not contain vertical scale factors, 770 !! they are set to the _0 values 771 !! if the restart does not contain vertical scale factors increments (z_tilde), 772 !! they are set to 0. 768 !! ** Method : * restart comes from a linear ssh simulation : 769 !! an attempt to read e3t_n stops simulation 770 !! * restart comes from a z-star, z-tilde, or layer : 771 !! read e3t_n and e3t_b 772 !! * restart comes from a z-star : 773 !! set tilde_e3t_n, tilde_e3t_n, and hdiv_lf to 0 774 !! * restart comes from layer : 775 !! read tilde_e3t_n and tilde_e3t_b 776 !! set hdiv_lf to 0 777 !! * restart comes from a z-tilde: 778 !! read tilde_e3t_n, tilde_e3t_b, and hdiv_lf 779 !! 780 !! NB: if l_1st_euler = T (ln_1st_euler or ssh_b not found) 781 !! Kbb fields set to Kmm ones 773 782 !!---------------------------------------------------------------------- 774 783 INTEGER , INTENT(in) :: kt ! ocean time-step … … 776 785 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 777 786 ! 778 INTEGER :: ji, jj, jk 779 INTEGER :: id 1, id2, id3, id4, id5! local integers780 !!---------------------------------------------------------------------- 781 ! 782 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise783 ! ! ===============784 IF( ln_rstart ) THEN !* Read the restart file785 CALL rst_read_open ! open the restart file if necessary786 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) )787 INTEGER :: ji, jj, jk ! dummy loop indices 788 INTEGER :: id3, id4, id5 ! local integers 789 !!---------------------------------------------------------------------- 790 ! 791 ! !=====================! 792 IF( TRIM(cdrw) == 'READ' ) THEN ! Read / initialise ! 793 ! !=====================! 794 ! 795 IF( ln_rstart ) THEN !== Read the restart file ==! 787 796 ! 788 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 789 id2 = iom_varid( numror, 'e3t_n', ldstop = .FALSE. ) 790 id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) 797 CALL rst_read_open !* open the restart file if necessary 798 ! ! --------- ! 799 ! ! all cases ! 800 ! ! --------- ! 801 ! 802 id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) !* check presence 791 803 id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. ) 792 id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. )804 id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. ) 793 805 ! 794 ! ! --------- ! 795 ! ! all cases ! 796 ! ! --------- ! 797 ! 798 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 806 ! !* scale factors 807 IF(lwp) WRITE(numout,*) ' Kmm scale factor read in the restart file' 808 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 809 WHERE ( tmask(:,:,:) == 0.0_wp ) 810 e3t(:,:,:,Kmm) = e3t_0(:,:,:) 811 END WHERE 812 IF( l_1st_euler ) THEN ! euler 813 IF(lwp) WRITE(numout,*) ' Euler first time step : e3t(Kbb) = e3t(Kmm)' 814 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 815 ELSE ! leap frog 816 IF(lwp) WRITE(numout,*) ' Kbb scale factor read in the restart file' 799 817 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 800 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) )801 ! needed to restart if land processor not computed802 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files'803 818 WHERE ( tmask(:,:,:) == 0.0_wp ) 804 e3t(:,:,:,Kmm) = e3t_0(:,:,:)805 819 e3t(:,:,:,Kbb) = e3t_0(:,:,:) 806 820 END WHERE 807 IF( l_1st_euler ) THEN808 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)809 ENDIF810 ELSE IF( id1 > 0 ) THEN811 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart files'812 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.'813 IF(lwp) write(numout,*) 'l_1st_euler is forced to true'814 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) )815 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb)816 l_1st_euler = .true.817 ELSE IF( id2 > 0 ) THEN818 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kbb) not found in restart files'819 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.'820 IF(lwp) write(numout,*) 'l_1st_euler is forced to true'821 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) )822 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)823 l_1st_euler = .true.824 ELSE825 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart file'826 IF(lwp) write(numout,*) 'Compute scale factor from sshn'827 IF(lwp) write(numout,*) 'l_1st_euler is forced to true'828 DO jk = 1, jpk829 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) &830 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &831 & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk))832 END DO833 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)834 l_1st_euler = .true.835 821 ENDIF 836 ! !----------- !837 IF( ln_vvl_zstar ) THEN !z_star case !838 ! !----------- !822 ! ! ------------ ! 823 IF( ln_vvl_zstar ) THEN ! z_star case ! 824 ! ! ------------ ! 839 825 IF( MIN( id3, id4 ) > 0 ) THEN 840 826 CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' ) 841 827 ENDIF 842 ! ! ----------------------- ! 843 ELSE ! z_tilde and layer cases ! 844 ! ! ----------------------- ! 845 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 846 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 828 ! ! ------------------------ ! 829 ELSE ! z_tilde and layer cases ! 830 ! ! ------------------------ ! 831 ! 832 IF( id4 > 0 ) THEN !* scale factor increments 833 IF(lwp) WRITE(numout,*) ' Kmm scale factor increments read in the restart file' 847 834 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 848 ELSE ! one at least array is missing 835 IF( l_1st_euler ) THEN ! euler 836 IF(lwp) WRITE(numout,*) ' Euler first time step : tilde_e3t(Kbb) = tilde_e3t(Kmm)' 837 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 838 ELSE ! leap frog 839 IF(lwp) WRITE(numout,*) ' Kbb scale factor increments read in the restart file' 840 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 841 ENDIF 842 ELSE 849 843 tilde_e3t_b(:,:,:) = 0.0_wp 850 844 tilde_e3t_n(:,:,:) = 0.0_wp 851 845 ENDIF 852 ! ! ------------ !853 IF( ln_vvl_ztilde ) THEN ! z_tilde case !854 ! ! ------------ !846 ! ! ------------ ! 847 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 848 ! ! ------------ ! 855 849 IF( id5 > 0 ) THEN ! required array exists 856 850 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 857 851 ELSE ! array is missing 858 hdiv_lf(:,:,:) = 0.0_wp 852 hdiv_lf(:,:,:) = 0.0_wp 859 853 ENDIF 860 854 ENDIF 861 855 ENDIF 862 856 ! 863 ELSE ! * Initialize at "rest"857 ELSE !== Initialize at "rest" with ssh ==! 864 858 ! 865 866 IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential 867 ! 868 IF( cn_cfg == 'wad' ) THEN 869 ! Wetting and drying test case 870 CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 871 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 872 ssh (:,:,Kmm) = ssh(:,:,Kbb) 873 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 874 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) 875 ELSE 876 ! if not test case 877 ssh(:,:,Kmm) = -ssh_ref 878 ssh(:,:,Kbb) = -ssh_ref 879 880 DO_2D( 1, 1, 1, 1 ) 881 IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth 882 ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) ) 883 ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) ) 884 ENDIF 885 END_2D 886 ENDIF !If test case else 887 888 ! Adjust vertical metrics for all wad 889 DO jk = 1, jpk 890 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 891 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 892 & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 893 END DO 894 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 895 896 DO_2D( 1, 1, 1, 1 ) 897 IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN 898 CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' ) 899 ENDIF 900 END_2D 901 ! 902 ELSE 903 ! 904 ! Just to read set ssh in fact, called latter once vertical grid 905 ! is set up: 906 ! CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 907 ! ! 908 ! DO jk=1,jpk 909 ! e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) & 910 ! & / ( ht_0(:,:) + 1._wp -ssmask(:,:) ) * tmask(:,:,jk) 911 ! END DO 912 ! e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 913 ssh(:,:,Kmm)=0._wp 914 e3t(:,:,:,Kmm)=e3t_0(:,:,:) 915 e3t(:,:,:,Kbb)=e3t_0(:,:,:) 916 ! 917 END IF ! end of ll_wd edits 918 859 DO jk = 1, jpk 860 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) ) 861 END DO 862 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 863 ! 919 864 IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN 920 865 tilde_e3t_b(:,:,:) = 0._wp 921 866 tilde_e3t_n(:,:,:) = 0._wp 922 867 IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0._wp 923 END 868 ENDIF 924 869 ENDIF 925 ! 926 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file 927 ! ! =================== 870 ! !=======================! 871 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file ! 872 ! !=======================! 873 ! 928 874 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 929 875 ! ! --------- ! -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/domzgr_substitute.h90
r13237 r14062 15 15 # define e3u(i,j,k,t) (e3u_0(i,j,k)*(1._wp+r3u(i,j,t)*umask(i,j,k))) 16 16 # define e3v(i,j,k,t) (e3v_0(i,j,k)*(1._wp+r3v(i,j,t)*vmask(i,j,k))) 17 # define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j)*fmask(i,j,k))) 17 # define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) 18 # define e3f_vor(i,j,k) (e3f_0vor(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) 18 19 # define e3w(i,j,k,t) (e3w_0(i,j,k)*(1._wp+r3t(i,j,t))) 19 20 # define e3uw(i,j,k,t) (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t))) 20 21 # define e3vw(i,j,k,t) (e3vw_0(i,j,k)*(1._wp+r3v(i,j,t))) 21 # define ht(i,j) (ht_0(i,j) +ssh(i,j,Kmm))22 # define ht(i,j) (ht_0(i,j)*(1._wp+r3t(i,j,Kmm))) 22 23 # define hu(i,j,t) (hu_0(i,j)*(1._wp+r3u(i,j,t))) 23 24 # define hv(i,j,t) (hv_0(i,j)*(1._wp+r3v(i,j,t))) … … 29 30 #endif 30 31 !!---------------------------------------------------------------------- 32 !!# define e3t_f(i,j,k) (e3t_0(i,j,k)*(1._wp+r3t_f(i,j)*tmask(i,j,k))) 33 !!# define e3u_f(i,j,k) (e3u_0(i,j,k)*(1._wp+r3u_f(i,j)*umask(i,j,k))) 34 !!# define e3v_f(i,j,k) (e3v_0(i,j,k)*(1._wp+r3v_f(i,j)*vmask(i,j,k))) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/istate.F90
r13295 r14062 42 42 PRIVATE 43 43 44 PUBLIC istate_init ! routine called by step.F9044 PUBLIC istate_init ! routine called by nemogcm.F90 45 45 46 46 !! * Substitutions … … 59 59 !! 60 60 !! ** Purpose : Initialization of the dynamics and tracer fields. 61 !! 62 !! ** Method : 61 63 !!---------------------------------------------------------------------- 62 64 INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! ocean time level indices 63 65 ! 64 66 INTEGER :: ji, jj, jk ! dummy loop indices 65 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table !!st patch to use gdept subtitute67 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table for qco substitute 66 68 !!gm see comment further down 67 69 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace … … 73 75 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 74 76 75 !!gm Why not include in the first call of dta_tsd ?76 !!gm probably associated with the use of internal damping...77 77 CALL dta_tsd_init ! Initialisation of T & S input data 78 !!gm to be moved in usrdef of C1D case 78 79 79 ! IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data 80 !!gm81 80 82 rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk83 rn2b (:,:,: ) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk84 ts (:,:,:,:,Kaa) = 0._wp ! set one for all to 0 at level jpk85 rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk81 rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk 82 rn2b (:,:,: ) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk 83 ts (:,:,:,:,Kaa) = 0._wp ! set one for all to 0 at level jpk 84 rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk 86 85 #if defined key_agrif 87 86 uu (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization … … 96 95 CALL agrif_istate( Kbb, Kmm, Kaa ) ! Interp from parent 97 96 ! 98 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) 99 ssh (:,:,Kmm) = ssh(:,:,Kbb) 100 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 101 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) 97 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) 98 !!st 99 !!st need for a recent agrif version to be displaced toward ssh_init_rst with agrif_istate_ssh 100 ssh(:,:, Kmm) = ssh(:,: ,Kbb) 101 !!st end 102 uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) 103 vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) 102 104 ELSE 103 105 #endif … … 117 119 CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 118 120 ! 119 ssh(:,:,Kbb) = 0._wp ! set the ocean at rest 120 uu (:,:,:,Kbb) = 0._wp 121 vv (:,:,:,Kbb) = 0._wp 121 uu (:,:,:,Kbb) = 0._wp 122 vv (:,:,:,Kbb) = 0._wp 122 123 ! 123 IF( ll_wd ) THEN124 ssh(:,:,Kbb) = -ssh_ref ! Added in 30 here for bathy that adds 30 as Iterative test CEOD125 !126 ! Apply minimum wetdepth criterion127 !128 DO_2D( 1, 1, 1, 1 )129 IF( ht_0(ji,jj) + ssh(ji,jj,Kbb) < rn_wdmin1 ) THEN130 ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) )131 ENDIF132 END_2D133 ENDIF134 !135 124 ELSE ! user defined initial T and S 136 125 DO jk = 1, jpk 137 126 zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 138 127 END DO 139 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) , ssh(:,:,Kbb) )128 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) 140 129 ENDIF 141 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 142 ssh (:,:,Kmm) = ssh(:,:,Kbb) 143 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 144 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) 145 146 !!gm POTENTIAL BUG : 147 !!gm ISSUE : if ssh(:,:,Kbb) /= 0 then, in non linear free surface, the e3._n, e3._b should be recomputed 148 !! as well as gdept_ and gdepw_.... !!!!! 149 !! ===>>>> probably a call to domvvl initialisation here.... 150 130 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 131 uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) 132 vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) 151 133 152 134 ! 153 !!gm to be moved in usrdef of C1D case154 !IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000155 !ALLOCATE( zuvd(jpi,jpj,jpk,2) )156 ! CALL dta_uvd( nit000, zuvd )157 ! uu(:,:,:,Kbb) = zuvd(:,:,:,1); uu(:,:,:,Kmm) = uu(:,:,:,Kbb)158 ! vv(:,:,:,Kbb) = zuvd(:,:,:,2); vv(:,:,:,Kmm) = vv(:,:,:,Kbb)159 !DEALLOCATE( zuvd )160 !ENDIF135 !!gm ==>>> to be moved in usrdef_istate of C1D case 136 IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 137 ALLOCATE( zuvd(jpi,jpj,jpk,2) ) 138 CALL dta_uvd( nit000, Kbb, zuvd ) 139 uu(:,:,:,Kbb) = zuvd(:,:,:,1) ; uu(:,:,:,Kmm) = uu(:,:,:,Kbb) 140 vv(:,:,:,Kbb) = zuvd(:,:,:,2) ; vv(:,:,:,Kmm) = vv(:,:,:,Kbb) 141 DEALLOCATE( zuvd ) 142 ENDIF 161 143 ! 162 !!gm This is to be changed !!!!163 ! ! - ML - ssh(:,:,Kmm) could be modified by istate_eel, so that initialization of e3t(:,:,:,Kbb) is done here164 ! IF( .NOT.ln_linssh ) THEN165 ! DO jk = 1, jpk166 ! e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm)167 ! END DO168 ! ENDIF169 !!gm170 144 ! 171 145 ENDIF -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DOM/phycst.F90
r12489 r14062 66 66 REAL(wp), PUBLIC :: r1_rhos !: 1 / rhos 67 67 REAL(wp), PUBLIC :: r1_rcpi !: 1 / rcpi 68 68 69 !!---------------------------------------------------------------------- 69 70 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynadv.F90
r12377 r14062 127 127 IF( ioptio /= 1 ) CALL ctl_stop( 'choose ONE and only ONE advection scheme' ) 128 128 IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW ) CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) 129 129 #if defined key_qcoTest_FluxForm 130 IF( ln_dynadv_vec ) THEN CALL ctl_stop( 'STOP', 'key_qcoTest_FluxForm requires flux form advection' ) 131 #endif 130 132 131 133 IF(lwp) THEN ! Print the choice -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynatf_qco.F90
r13295 r14062 1 MODULE dynatf qco1 MODULE dynatf_qco 2 2 !!========================================================================= 3 !! *** MODULE dynatf qco ***3 !! *** MODULE dynatf_qco *** 4 4 !! Ocean dynamics: time filtering 5 5 !!========================================================================= … … 50 50 USE prtctl ! Print control 51 51 USE timing ! Timing 52 #if defined key_agrif53 USE agrif_oce_interp54 #endif55 52 56 53 IMPLICIT NONE … … 199 196 ! JC: Would be more clever to swap variables than to make a full vertical 200 197 ! integration 201 ! 198 ! CAUTION : calculation need to be done in the same way than see GM 202 199 uu_b(:,:,Kaa) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) 203 uu_b(:,:,Kmm) = e3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1)200 uu_b(:,:,Kmm) = (e3u_0(:,:,1) * ( 1._wp + r3u_f(:,:) * umask(:,:,1) )) * puu(:,:,1,Kmm) * umask(:,:,1) 204 201 vv_b(:,:,Kaa) = e3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1) 205 vv_b(:,:,Kmm) = e3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1)202 vv_b(:,:,Kmm) = (e3v_0(:,:,1) * ( 1._wp + r3v_f(:,:) * vmask(:,:,1))) * pvv(:,:,1,Kmm) * vmask(:,:,1) 206 203 DO jk = 2, jpkm1 207 204 uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + e3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk) 208 uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk)205 uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + (e3u_0(:,:,jk) * ( 1._wp + r3u_f(:,:) * umask(:,:,jk) )) * puu(:,:,jk,Kmm) * umask(:,:,jk) 209 206 vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + e3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) 210 vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk)207 vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + (e3v_0(:,:,jk) * ( 1._wp + r3v_f(:,:) * vmask(:,:,jk) )) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) 211 208 END DO 212 209 uu_b(:,:,Kaa) = uu_b(:,:,Kaa) * r1_hu(:,:,Kaa) 213 210 vv_b(:,:,Kaa) = vv_b(:,:,Kaa) * r1_hv(:,:,Kaa) 214 uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm)215 vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm)211 uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * (r1_hu_0(:,:)/( 1._wp + r3u_f(:,:) )) 212 vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * (r1_hv_0(:,:)/( 1._wp + r3v_f(:,:) )) 216 213 ! 217 214 IF( .NOT.ln_dynspg_ts ) THEN ! output the barotropic currents … … 235 232 236 233 !!========================================================================= 237 END MODULE dynatf qco234 END MODULE dynatf_qco -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynhpg.F90
r14037 r14062 17 17 !! ! (A. Coward) suppression of hel, wdj and rot options 18 18 !! 3.6 ! 2014-11 (P. Mathiot) hpg_isf: original code for ice shelf cavity 19 !! 4.2 ! 2020-12 (M. Bell, A. Young) hpg_djc: revised djc scheme 19 20 !!---------------------------------------------------------------------- 20 21 … … 72 73 INTEGER, PARAMETER :: np_isf = 5 ! s-coordinate similar to sco modify for isf 73 74 ! 74 INTEGER, PUBLIC :: nhpg !: type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) (PUBLIC for TAM) 75 INTEGER, PUBLIC :: nhpg !: type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) (PUBLIC for TAM) 76 ! 77 LOGICAL :: ln_hpg_djc_vnh, ln_hpg_djc_vnv ! flag to specify hpg_djc boundary condition type 78 REAL(wp), PUBLIC :: aco_bc_hor, bco_bc_hor, aco_bc_vrt, bco_bc_vrt !: coefficients for hpg_djc hor and vert boundary conditions 75 79 76 80 !! * Substitutions … … 155 159 !! 156 160 NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco, & 157 & ln_hpg_djc, ln_hpg_prj, ln_hpg_isf 161 & ln_hpg_djc, ln_hpg_prj, ln_hpg_isf, & 162 & ln_hpg_djc_vnh, ln_hpg_djc_vnv 158 163 !!---------------------------------------------------------------------- 159 164 ! … … 178 183 ENDIF 179 184 ! 180 IF( ln_hpg_djc ) & 181 & CALL ctl_stop('dyn_hpg_init : Density Jacobian: Cubic polynominal method', & 182 & ' currently disabled (bugs under investigation).' , & 183 & ' Please select either ln_hpg_sco or ln_hpg_prj instead' ) 184 ! 185 IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) ) & 185 IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf.OR.ln_hpg_djc) ) & 186 186 & CALL ctl_stop('dyn_hpg_init : non-linear free surface requires either ', & 187 187 & ' the standard jacobian formulation hpg_sco or ' , & … … 219 219 ENDIF 220 220 ! 221 IF ( ln_hpg_djc ) THEN 222 IF (ln_hpg_djc_vnh) THEN ! Von Neumann boundary condition 223 IF(lwp) WRITE(numout,*) ' horizontal bc: von Neumann ' 224 aco_bc_hor = 6.0_wp/5.0_wp 225 bco_bc_hor = 7.0_wp/15.0_wp 226 ELSE ! Linear extrapolation 227 IF(lwp) WRITE(numout,*) ' horizontal bc: linear extrapolation' 228 aco_bc_hor = 3.0_wp/2.0_wp 229 bco_bc_hor = 1.0_wp/2.0_wp 230 END IF 231 IF (ln_hpg_djc_vnv) THEN ! Von Neumann boundary condition 232 IF(lwp) WRITE(numout,*) ' vertical bc: von Neumann ' 233 aco_bc_vrt = 6.0_wp/5.0_wp 234 bco_bc_vrt = 7.0_wp/15.0_wp 235 ELSE ! Linear extrapolation 236 IF(lwp) WRITE(numout,*) ' vertical bc: linear extrapolation' 237 aco_bc_vrt = 3.0_wp/2.0_wp 238 bco_bc_vrt = 1.0_wp/2.0_wp 239 END IF 240 END IF 221 241 END SUBROUTINE dyn_hpg_init 222 242 … … 612 632 !! 613 633 INTEGER :: ji, jj, jk ! dummy loop indices 634 INTEGER :: iktb, iktt ! jk indices at tracer points for top and bottom points 614 635 REAL(wp) :: zcoef0, zep, cffw ! temporary scalars 615 REAL(wp) :: z1_10, cffu, cffx ! " " 616 REAL(wp) :: z1_12, cffv, cffy ! " " 636 REAL(wp) :: z_grav_10, z1_12 637 REAL(wp) :: cffu, cffx ! " " 638 REAL(wp) :: cffv, cffy ! " " 617 639 LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables 618 REAL(wp), DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace619 640 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 620 REAL(wp), DIMENSION(jpi,jpj,jpk) :: dzx, dzy, dzz, dzu, dzv, dzw 621 REAL(wp), DIMENSION(jpi,jpj,jpk) :: drhox, drhoy, drhoz, drhou, drhov, drhow 622 REAL(wp), DIMENSION(jpi,jpj,jpk) :: rho_i, rho_j, rho_k 641 642 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdzx, zdzy, zdzz ! Primitive grid differences ('delta_xyz') 643 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdz_i, zdz_j, zdz_k ! Harmonic average of primitive grid differences ('d_xyz') 644 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdrhox, zdrhoy, zdrhoz ! Primitive rho differences ('delta_rho') 645 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdrho_i, zdrho_j, zdrho_k ! Harmonic average of primitive rho differences ('d_rho') 646 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z_rho_i, z_rho_j, z_rho_k ! Face intergrals 647 REAL(wp), DIMENSION(jpi,jpj) :: zz_dz_i, zz_dz_j, zz_drho_i, zz_drho_j ! temporary arrays 623 648 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter 624 649 !!---------------------------------------------------------------------- … … 673 698 ! Local constant initialization 674 699 zcoef0 = - grav * 0.5_wp 675 z 1_10 = 1._wp/ 10._wp676 z1_12 = 1. _wp / 12._wp700 z_grav_10 = grav / 10._wp 701 z1_12 = 1.0_wp / 12._wp 677 702 678 703 !---------------------------------------------------------------------------------------- 679 ! compute and store in provisional arrays elementary vertical and horizontal differences704 ! 1. compute and store elementary vertical differences in provisional arrays 680 705 !---------------------------------------------------------------------------------------- 681 706 682 !!bug gm Not a true bug, but... dzz=e3w for dzx, dzy verify what it is really 683 684 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 685 drhoz(ji,jj,jk) = rhd (ji ,jj ,jk) - rhd (ji,jj,jk-1) 686 dzz (ji,jj,jk) = gde3w(ji ,jj ,jk) - gde3w(ji,jj,jk-1) 687 drhox(ji,jj,jk) = rhd (ji+1,jj ,jk) - rhd (ji,jj,jk ) 688 dzx (ji,jj,jk) = gde3w(ji+1,jj ,jk) - gde3w(ji,jj,jk ) 689 drhoy(ji,jj,jk) = rhd (ji ,jj+1,jk) - rhd (ji,jj,jk ) 690 dzy (ji,jj,jk) = gde3w(ji ,jj+1,jk) - gde3w(ji,jj,jk ) 707 !!bug gm Not a true bug, but... zdzz=e3w for zdzx, zdzy verify what it is really 708 709 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 710 zdrhoz(ji,jj,jk) = rhd (ji ,jj ,jk) - rhd (ji,jj,jk-1) 711 zdzz (ji,jj,jk) = - gde3w(ji ,jj ,jk) + gde3w(ji,jj,jk-1) 691 712 END_3D 692 713 693 714 !------------------------------------------------------------------------- 694 ! compute harmonic averages using eq. 5.18715 ! 2. compute harmonic averages for vertical differences using eq. 5.18 695 716 !------------------------------------------------------------------------- 696 717 zep = 1.e-15 697 718 698 !!bug gm drhoz not defined at level 1 and used (jk-1 with jk=2) 699 !!bug gm idem for drhox, drhoy et ji=jpi and jj=jpj 700 701 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 702 cffw = 2._wp * drhoz(ji ,jj ,jk) * drhoz(ji,jj,jk-1) 703 704 cffu = 2._wp * drhox(ji+1,jj ,jk) * drhox(ji,jj,jk ) 705 cffx = 2._wp * dzx (ji+1,jj ,jk) * dzx (ji,jj,jk ) 706 707 cffv = 2._wp * drhoy(ji ,jj+1,jk) * drhoy(ji,jj,jk ) 708 cffy = 2._wp * dzy (ji ,jj+1,jk) * dzy (ji,jj,jk ) 709 719 !! mb zdrho_k, zdz_k, zdrho_i, zdz_i, zdrho_j, zdz_j re-centred about the point (ji,jj,jk) 720 zdrho_k(:,:,:) = 0._wp 721 zdz_k (:,:,:) = 0._wp 722 723 DO_3D( 1, 1, 1, 1, 2, jpk-2 ) 724 cffw = 2._wp * zdrhoz(ji ,jj ,jk) * zdrhoz(ji,jj,jk+1) 710 725 IF( cffw > zep) THEN 711 drhow(ji,jj,jk) = 2._wp * drhoz(ji,jj,jk) * drhoz(ji,jj,jk-1) & 712 & / ( drhoz(ji,jj,jk) + drhoz(ji,jj,jk-1) ) 726 zdrho_k(ji,jj,jk) = cffw / ( zdrhoz(ji,jj,jk) + zdrhoz(ji,jj,jk+1) ) 727 ENDIF 728 zdz_k(ji,jj,jk) = 2._wp * zdzz(ji,jj,jk) * zdzz(ji,jj,jk+1) & 729 & / ( zdzz(ji,jj,jk) + zdzz(ji,jj,jk+1) ) 730 END_3D 731 732 !---------------------------------------------------------------------------------- 733 ! 3. apply boundary conditions at top and bottom using 5.36-5.37 734 !---------------------------------------------------------------------------------- 735 736 ! mb for sea-ice shelves we will need to re-write this upper boundary condition in the same form as the lower boundary condition 737 zdrho_k(:,:,1) = aco_bc_vrt * ( rhd (:,:,2) - rhd (:,:,1) ) - bco_bc_vrt * zdrho_k(:,:,2) 738 zdz_k (:,:,1) = aco_bc_vrt * (-gde3w(:,:,2) + gde3w(:,:,1) ) - bco_bc_vrt * zdz_k (:,:,2) 739 740 DO_2D( 1, 1, 1, 1 ) 741 IF ( mbkt(ji,jj)>1 ) THEN 742 iktb = mbkt(ji,jj) 743 zdrho_k(ji,jj,iktb) = aco_bc_vrt * ( rhd(ji,jj,iktb) - rhd(ji,jj,iktb-1) ) - bco_bc_vrt * zdrho_k(ji,jj,iktb-1) 744 zdz_k (ji,jj,iktb) = aco_bc_vrt * (-gde3w(ji,jj,iktb) + gde3w(ji,jj,iktb-1) ) - bco_bc_vrt * zdz_k (ji,jj,iktb-1) 745 END IF 746 END_2D 747 748 !-------------------------------------------------------------- 749 ! 4. Compute side face integrals 750 !------------------------------------------------------------- 751 752 !! ssh replaces e3w_n ; gde3w is a depth; the formulae involve heights 753 !! rho_k stores grav * FX / rho_0 754 755 !-------------------------------------------------------------- 756 ! 4. a) Upper half of top-most grid box, compute and store 757 !------------------------------------------------------------- 758 ! *** AY note: ssh(ji,jj,Kmm) + gde3w(ji,jj,1) = e3w(ji,jj,1) 759 DO_2D( 0, 1, 0, 1) 760 z_rho_k(ji,jj,1) = grav * ( ssh(ji,jj,Kmm) + gde3w(ji,jj,1) ) & 761 & * ( rhd(ji,jj,1) & 762 & + 0.5_wp * ( rhd (ji,jj,2) - rhd (ji,jj,1) ) & 763 & * ( ssh (ji,jj,Kmm) + gde3w(ji,jj,1) ) & 764 & / ( - gde3w(ji,jj,2) + gde3w(ji,jj,1) ) ) 765 END_2D 766 767 !-------------------------------------------------------------- 768 ! 4. b) Interior faces, compute and store 769 !------------------------------------------------------------- 770 771 DO_3D( 0, 1, 0, 1, 2, jpkm1 ) 772 z_rho_k(ji,jj,jk) = zcoef0 * ( rhd (ji,jj,jk) + rhd (ji,jj,jk-1) ) & 773 & * ( - gde3w(ji,jj,jk) + gde3w(ji,jj,jk-1) ) & 774 & + z_grav_10 * ( & 775 & ( zdrho_k (ji,jj,jk) - zdrho_k (ji,jj,jk-1) ) & 776 & * ( - gde3w(ji,jj,jk) + gde3w(ji,jj,jk-1) - z1_12 * ( zdz_k (ji,jj,jk) + zdz_k (ji,jj,jk-1) ) ) & 777 & - ( zdz_k (ji,jj,jk) - zdz_k (ji,jj,jk-1) ) & 778 & * ( rhd (ji,jj,jk) - rhd (ji,jj,jk-1) - z1_12 * ( zdrho_k(ji,jj,jk) + zdrho_k(ji,jj,jk-1) ) ) & 779 & ) 780 END_3D 781 782 !---------------------------------------------------------------------------------------- 783 ! 5. compute and store elementary horizontal differences in provisional arrays 784 !---------------------------------------------------------------------------------------- 785 786 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 787 zdrhox(ji,jj,jk) = rhd (ji+1,jj ,jk) - rhd (ji,jj,jk ) 788 zdzx (ji,jj,jk) = - gde3w(ji+1,jj ,jk) + gde3w(ji,jj,jk ) 789 zdrhoy(ji,jj,jk) = rhd (ji ,jj+1,jk) - rhd (ji,jj,jk ) 790 zdzy (ji,jj,jk) = - gde3w(ji ,jj+1,jk) + gde3w(ji,jj,jk ) 791 END_3D 792 793 CALL lbc_lnk_multi( 'dynhpg', zdrhox, 'U', 1., zdzx, 'U', 1., zdrhoy, 'V', 1., zdzy, 'V', 1. ) 794 795 !------------------------------------------------------------------------- 796 ! 6. compute harmonic averages using eq. 5.18 797 !------------------------------------------------------------------------- 798 799 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) 800 cffu = 2._wp * zdrhox(ji-1,jj ,jk) * zdrhox(ji,jj,jk ) 801 IF( cffu > zep ) THEN 802 zdrho_i(ji,jj,jk) = cffu / ( zdrhox(ji-1,jj,jk) + zdrhox(ji,jj,jk) ) 713 803 ELSE 714 drhow(ji,jj,jk) = 0._wp 715 ENDIF 716 717 dzw(ji,jj,jk) = 2._wp * dzz(ji,jj,jk) * dzz(ji,jj,jk-1) & 718 & / ( dzz(ji,jj,jk) + dzz(ji,jj,jk-1) ) 719 720 IF( cffu > zep ) THEN 721 drhou(ji,jj,jk) = 2._wp * drhox(ji+1,jj,jk) * drhox(ji,jj,jk) & 722 & / ( drhox(ji+1,jj,jk) + drhox(ji,jj,jk) ) 804 zdrho_i(ji,jj,jk ) = 0._wp 805 ENDIF 806 807 cffx = 2._wp * zdzx (ji-1,jj ,jk) * zdzx (ji,jj,jk ) 808 IF( cffx > zep ) THEN 809 zdz_i(ji,jj,jk) = cffx / ( zdzx(ji-1,jj,jk) + zdzx(ji,jj,jk) ) 723 810 ELSE 724 drhou(ji,jj,jk) = 0._wp725 ENDIF 726 727 IF( cffx > zep ) THEN728 dzu(ji,jj,jk) = 2._wp * dzx(ji+1,jj,jk) * dzx(ji,jj,jk) &729 & / ( dzx(ji+1,jj,jk) + dzx(ji,jj,jk) )811 zdz_i(ji,jj,jk) = 0._wp 812 ENDIF 813 814 cffv = 2._wp * zdrhoy(ji ,jj-1,jk) * zdrhoy(ji,jj,jk ) 815 IF( cffv > zep ) THEN 816 zdrho_j(ji,jj,jk) = cffv / ( zdrhoy(ji,jj-1,jk) + zdrhoy(ji,jj,jk) ) 730 817 ELSE 731 dzu(ji,jj,jk) = 0._wp732 ENDIF 733 734 IF( cffv > zep ) THEN735 drhov(ji,jj,jk) = 2._wp * drhoy(ji,jj+1,jk) * drhoy(ji,jj,jk) &736 & / ( drhoy(ji,jj+1,jk) + drhoy(ji,jj,jk) )818 zdrho_j(ji,jj,jk) = 0._wp 819 ENDIF 820 821 cffy = 2._wp * zdzy (ji ,jj-1,jk) * zdzy (ji,jj,jk ) 822 IF( cffy > zep ) THEN 823 zdz_j(ji,jj,jk) = cffy / ( zdzy(ji,jj-1,jk) + zdzy(ji,jj,jk) ) 737 824 ELSE 738 drhov(ji,jj,jk) = 0._wp 739 ENDIF 740 741 IF( cffy > zep ) THEN 742 dzv(ji,jj,jk) = 2._wp * dzy(ji,jj+1,jk) * dzy(ji,jj,jk) & 743 & / ( dzy(ji,jj+1,jk) + dzy(ji,jj,jk) ) 744 ELSE 745 dzv(ji,jj,jk) = 0._wp 746 ENDIF 747 748 END_3D 825 zdz_j(ji,jj,jk) = 0._wp 826 ENDIF 827 END_3D 828 829 !!! Note that zdzx, zdzy, zdzz, zdrhox, zdrhoy and zdrhoz should NOT be used beyond this point 749 830 750 831 !---------------------------------------------------------------------------------- 751 ! apply boundary conditions at top and bottomusing 5.36-5.37832 ! 6B. apply boundary conditions at side boundaries using 5.36-5.37 752 833 !---------------------------------------------------------------------------------- 753 drhow(:,:, 1 ) = 1.5_wp * ( drhoz(:,:, 2 ) - drhoz(:,:, 1 ) ) - 0.5_wp * drhow(:,:, 2 ) 754 drhou(:,:, 1 ) = 1.5_wp * ( drhox(:,:, 2 ) - drhox(:,:, 1 ) ) - 0.5_wp * drhou(:,:, 2 ) 755 drhov(:,:, 1 ) = 1.5_wp * ( drhoy(:,:, 2 ) - drhoy(:,:, 1 ) ) - 0.5_wp * drhov(:,:, 2 ) 756 757 drhow(:,:,jpk) = 1.5_wp * ( drhoz(:,:,jpk) - drhoz(:,:,jpkm1) ) - 0.5_wp * drhow(:,:,jpkm1) 758 drhou(:,:,jpk) = 1.5_wp * ( drhox(:,:,jpk) - drhox(:,:,jpkm1) ) - 0.5_wp * drhou(:,:,jpkm1) 759 drhov(:,:,jpk) = 1.5_wp * ( drhoy(:,:,jpk) - drhoy(:,:,jpkm1) ) - 0.5_wp * drhov(:,:,jpkm1) 760 834 835 DO jk = 1, jpkm1 836 zz_drho_i(:,:) = zdrho_i(:,:,jk) 837 zz_dz_i (:,:) = zdz_i (:,:,jk) 838 zz_drho_j(:,:) = zdrho_j(:,:,jk) 839 zz_dz_j (:,:) = zdz_j (:,:,jk) 840 DO_2D( 0, 1, 0, 1) 841 ! Walls coming from left: should check from 2 to jpi-1 (and jpj=2-jpj) 842 IF (ji < jpi) THEN 843 IF ( umask(ji,jj,jk) > 0.5_wp .AND. umask(ji-1,jj,jk) < 0.5_wp .AND. umask(ji+1,jj,jk) > 0.5_wp) THEN 844 zz_drho_i(ji,jj) = aco_bc_hor * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) ) - bco_bc_hor * zdrho_i(ji+1,jj,jk) 845 zz_dz_i (ji,jj) = aco_bc_hor * (-gde3w(ji+1,jj,jk) + gde3w(ji,jj,jk) ) - bco_bc_hor * zdz_i (ji+1,jj,jk) 846 END IF 847 END IF 848 ! Walls coming from right: should check from 3 to jpi (and jpj=2-jpj) 849 IF (ji > 2) THEN 850 IF ( umask(ji,jj,jk) < 0.5_wp .AND. umask(ji-1,jj,jk) > 0.5_wp .AND. umask(ji-2,jj,jk) > 0.5_wp) THEN 851 zz_drho_i(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk) - rhd (ji-1,jj,jk) ) - bco_bc_hor * zdrho_i(ji-1,jj,jk) 852 zz_dz_i (ji,jj) = aco_bc_hor * (-gde3w(ji,jj,jk) + gde3w(ji-1,jj,jk) ) - bco_bc_hor * zdz_i (ji-1,jj,jk) 853 END IF 854 END IF 855 ! Walls coming from left: should check from 2 to jpj-1 (and jpi=2-jpi) 856 IF (jj < jpj) THEN 857 IF ( vmask(ji,jj,jk) > 0.5_wp .AND. vmask(ji,jj-1,jk) < 0.5_wp .AND. vmask(ji,jj+1,jk) > 0.5_wp) THEN 858 zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) ) - bco_bc_hor * zdrho_j(ji,jj+1,jk) 859 zz_dz_j (ji,jj) = aco_bc_hor * (-gde3w(ji,jj+1,jk) + gde3w(ji,jj,jk) ) - bco_bc_hor * zdz_j (ji,jj+1,jk) 860 END IF 861 END IF 862 ! Walls coming from right: should check from 3 to jpj (and jpi=2-jpi) 863 IF (jj > 2) THEN 864 IF ( vmask(ji,jj,jk) < 0.5_wp .AND. vmask(ji,jj-1,jk) > 0.5_wp .AND. vmask(ji,jj-2,jk) > 0.5_wp) THEN 865 zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk) - rhd (ji,jj-1,jk) ) - bco_bc_hor * zdrho_j(ji,jj-1,jk) 866 zz_dz_j (ji,jj) = aco_bc_hor * (-gde3w(ji,jj,jk) + gde3w(ji,jj-1,jk) ) - bco_bc_hor * zdz_j (ji,jj-1,jk) 867 END IF 868 END IF 869 END_2D 870 zdrho_i(:,:,jk) = zz_drho_i(:,:) 871 zdz_i (:,:,jk) = zz_dz_i (:,:) 872 zdrho_j(:,:,jk) = zz_drho_j(:,:) 873 zdz_j (:,:,jk) = zz_dz_j (:,:) 874 END DO 761 875 762 876 !-------------------------------------------------------------- 763 ! Upper half of top-most grid box, compute and store877 ! 7. Calculate integrals on side faces 764 878 !------------------------------------------------------------- 765 879 766 !!bug gm : e3w-gde3w(:,:,:) = 0.5*e3w .... and gde3w(:,:,2)-gde3w(:,:,1)=e3w(:,:,2,Kmm) .... to be verified 767 ! true if gde3w(:,:,:) is really defined as the sum of the e3w scale factors as, it seems to me, it should be 768 769 DO_2D( 0, 0, 0, 0 ) 770 rho_k(ji,jj,1) = -grav * ( e3w(ji,jj,1,Kmm) - gde3w(ji,jj,1) ) & 771 & * ( rhd(ji,jj,1) & 772 & + 0.5_wp * ( rhd (ji,jj,2) - rhd (ji,jj,1) ) & 773 & * ( e3w (ji,jj,1,Kmm) - gde3w(ji,jj,1) ) & 774 & / ( gde3w(ji,jj,2) - gde3w(ji,jj,1) ) ) 775 END_2D 776 777 !!bug gm : here also, simplification is possible 778 !!bug gm : optimisation: 1/10 and 1/12 the division should be done before the loop 779 780 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 781 782 rho_k(ji,jj,jk) = zcoef0 * ( rhd (ji,jj,jk) + rhd (ji,jj,jk-1) ) & 783 & * ( gde3w(ji,jj,jk) - gde3w(ji,jj,jk-1) ) & 784 & - grav * z1_10 * ( & 785 & ( drhow (ji,jj,jk) - drhow (ji,jj,jk-1) ) & 786 & * ( gde3w(ji,jj,jk) - gde3w(ji,jj,jk-1) - z1_12 * ( dzw (ji,jj,jk) + dzw (ji,jj,jk-1) ) ) & 787 & - ( dzw (ji,jj,jk) - dzw (ji,jj,jk-1) ) & 788 & * ( rhd (ji,jj,jk) - rhd (ji,jj,jk-1) - z1_12 * ( drhow(ji,jj,jk) + drhow(ji,jj,jk-1) ) ) & 789 & ) 790 791 rho_i(ji,jj,jk) = zcoef0 * ( rhd (ji+1,jj,jk) + rhd (ji,jj,jk) ) & 792 & * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) ) & 793 & - grav* z1_10 * ( & 794 & ( drhou (ji+1,jj,jk) - drhou (ji,jj,jk) ) & 795 & * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) - z1_12 * ( dzu (ji+1,jj,jk) + dzu (ji,jj,jk) ) ) & 796 & - ( dzu (ji+1,jj,jk) - dzu (ji,jj,jk) ) & 797 & * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) - z1_12 * ( drhou(ji+1,jj,jk) + drhou(ji,jj,jk) ) ) & 798 & ) 799 800 rho_j(ji,jj,jk) = zcoef0 * ( rhd (ji,jj+1,jk) + rhd (ji,jj,jk) ) & 801 & * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) ) & 802 & - grav* z1_10 * ( & 803 & ( drhov (ji,jj+1,jk) - drhov (ji,jj,jk) ) & 804 & * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) - z1_12 * ( dzv (ji,jj+1,jk) + dzv (ji,jj,jk) ) ) & 805 & - ( dzv (ji,jj+1,jk) - dzv (ji,jj,jk) ) & 806 & * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) - z1_12 * ( drhov(ji,jj+1,jk) + drhov(ji,jj,jk) ) ) & 807 & ) 808 809 END_3D 810 CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1.0_wp, rho_i, 'U', 1.0_wp, rho_j, 'V', 1.0_wp ) 811 ! 812 ! --------------- 813 ! Surface pressure gradient to be removed 814 ! --------------- 815 DO_2D( 0, 0, 0, 0 ) 816 zpgu(ji,jj) = - grav * ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 817 zpgv(ji,jj) = - grav * ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) 818 END_2D 880 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 881 ! two -ve signs cancel in next two lines (within zcoef0 and because gde3w is a depth not a height) 882 z_rho_i(ji,jj,jk) = zcoef0 * ( rhd (ji+1,jj,jk) + rhd (ji,jj,jk) ) & 883 & * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) ) 884 IF ( umask(ji-1, jj, jk) > 0.5 .OR. umask(ji+1, jj, jk) > 0.5 ) THEN 885 z_rho_i(ji,jj,jk) = z_rho_i(ji,jj,jk) - z_grav_10 * ( & 886 & ( zdrho_i (ji+1,jj,jk) - zdrho_i (ji,jj,jk) ) & 887 & * ( - gde3w(ji+1,jj,jk) + gde3w(ji,jj,jk) - z1_12 * ( zdz_i (ji+1,jj,jk) + zdz_i (ji,jj,jk) ) ) & 888 & - ( zdz_i (ji+1,jj,jk) - zdz_i (ji,jj,jk) ) & 889 & * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) - z1_12 * ( zdrho_i(ji+1,jj,jk) + zdrho_i(ji,jj,jk) ) ) & 890 & ) 891 END IF 892 893 z_rho_j(ji,jj,jk) = zcoef0 * ( rhd (ji,jj+1,jk) + rhd (ji,jj,jk) ) & 894 & * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) ) 895 IF ( vmask(ji, jj-1, jk) > 0.5 .OR. vmask(ji, jj+1, jk) > 0.5 ) THEN 896 z_rho_j(ji,jj,jk) = z_rho_j(ji,jj,jk) - z_grav_10 * ( & 897 & ( zdrho_j (ji,jj+1,jk) - zdrho_j (ji,jj,jk) ) & 898 & * ( - gde3w(ji,jj+1,jk) + gde3w(ji,jj,jk) - z1_12 * ( zdz_j (ji,jj+1,jk) + zdz_j (ji,jj,jk) ) ) & 899 & - ( zdz_j (ji,jj+1,jk) - zdz_j (ji,jj,jk) ) & 900 & * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) - z1_12 * ( zdrho_j(ji,jj+1,jk) + zdrho_j(ji,jj,jk) ) ) & 901 & ) 902 END IF 903 END_3D 904 905 !-------------------------------------------------------------- 906 ! 8. Integrate in the vertical 907 !------------------------------------------------------------- 819 908 ! 820 909 ! --------------- … … 822 911 ! --------------- 823 912 DO_2D( 0, 0, 0, 0 ) 824 zhpi(ji,jj,1) = ( rho_k(ji+1,jj ,1) - rho_k(ji,jj,1) -rho_i(ji,jj,1) ) * r1_e1u(ji,jj)825 zhpj(ji,jj,1) = ( rho_k(ji ,jj+1,1) - rho_k(ji,jj,1) -rho_j(ji,jj,1) ) * r1_e2v(ji,jj)913 zhpi(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji+1,jj ,1) - z_rho_i(ji,jj,1) ) * r1_e1u(ji,jj) 914 zhpj(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji ,jj+1,1) - z_rho_j(ji,jj,1) ) * r1_e2v(ji,jj) 826 915 IF( ln_wd_il ) THEN 827 916 zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) … … 829 918 ENDIF 830 919 ! add to the general momentum trend 831 puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) - zpgu(ji,jj)832 pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) - zpgv(ji,jj)920 puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) 921 pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) 833 922 END_2D 834 923 … … 838 927 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 839 928 ! hydrostatic pressure gradient along s-surfaces 840 zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) &841 & + ( ( rho_k(ji+1,jj,jk) - rho_k(ji,jj,jk ) )&842 & - ( rho_i(ji ,jj,jk) - rho_i(ji,jj,jk-1) ) ) * r1_e1u(ji,jj)843 zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) &844 & + ( ( rho_k(ji,jj+1,jk) - rho_k(ji,jj,jk ) )&845 & -( rho_j(ji,jj ,jk) - rho_j(ji,jj,jk-1) ) ) * r1_e2v(ji,jj)929 zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) & 930 & + ( ( z_rho_k(ji,jj,jk) - z_rho_k(ji+1,jj,jk ) ) & 931 & - ( z_rho_i(ji,jj,jk) - z_rho_i(ji ,jj,jk-1) ) ) * r1_e1u(ji,jj) 932 zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) & 933 & + ( ( z_rho_k(ji,jj,jk) - z_rho_k(ji,jj+1,jk ) ) & 934 & -( z_rho_j(ji,jj,jk) - z_rho_j(ji,jj ,jk-1) ) ) * r1_e2v(ji,jj) 846 935 IF( ln_wd_il ) THEN 847 936 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) … … 849 938 ENDIF 850 939 ! add to the general momentum trend 851 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk) - zpgu(ji,jj)852 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk) - zpgv(ji,jj)940 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk) 941 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk) 853 942 END_3D 854 943 ! -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynldf_lap_blp.F90
r14037 r14062 5 5 !!====================================================================== 6 6 !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian 7 !! 4.0 ! 2020-04 (A. Nasser, G. Madec) Add symmetric mixing tensor 7 8 !!---------------------------------------------------------------------- 8 9 … … 19 20 USE in_out_manager ! I/O manager 20 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 22 USE lib_mpp 23 22 24 IMPLICIT NONE 23 25 PRIVATE … … 47 49 !! 48 50 !! ** Action : - pu_rhs, pv_rhs increased by the harmonic operator applied on pu, pv. 51 !! 52 !! Reference : S.Griffies, R.Hallberg 2000 Mon.Wea.Rev., DOI:/ 49 53 !!---------------------------------------------------------------------- 50 54 INTEGER , INTENT(in ) :: kt ! ocean time-step index … … 57 61 REAL(wp) :: zsign ! local scalars 58 62 REAL(wp) :: zua, zva ! local scalars 59 REAL(wp), DIMENSION(jpi,jpj) :: zcur, zdiv 63 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zcur, zdiv 64 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zten, zshe ! tension (diagonal) and shearing (anti-diagonal) terms 60 65 !!---------------------------------------------------------------------- 61 66 ! … … 70 75 ENDIF 71 76 ! 72 ! ! =============== 73 DO jk = 1, jpkm1 ! Horizontal slab 74 ! ! =============== 75 DO_2D( 0, 1, 0, 1 ) 76 ! ! ahm * e3 * curl (computed from 1 to jpim1/jpjm1) 77 zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & ! ahmf already * by fmask 78 & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & 79 & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) 80 ! ! ahm * div (computed from 2 to jpi/jpj) 81 zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & ! ahmt already * by tmask 82 & * ( e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk) & 83 & + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk) ) 84 END_2D 77 SELECT CASE( nn_dynldf_typ ) 78 ! 79 CASE ( np_typ_rot ) !== Vorticity-Divergence operator ==! 85 80 ! 86 DO_2D( 0, 0, 0, 0 ) ! - curl( curl) + grad( div ) 87 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use 88 & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & 89 & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) ) 81 ALLOCATE( zcur(jpi,jpj) , zdiv(jpi,jpj) ) 82 ! 83 DO jk = 1, jpkm1 ! Horizontal slab 84 ! 85 DO_2D( 0, 1, 0, 1 ) 86 ! ! ahm * e3 * curl (computed from 1 to jpim1/jpjm1) 87 zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & ! ahmf already * by fmask 88 & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & 89 & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) 90 ! ! ahm * div (computed from 2 to jpi/jpj) 91 zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & ! ahmt already * by tmask 92 & * ( e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk) & 93 & + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk) ) 94 END_2D 95 ! 96 DO_2D( 0, 0, 0, 0 ) ! - curl( curl) + grad( div ) 97 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use 98 & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & 99 & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) ) 90 100 ! 91 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use 92 & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm) & 93 & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) ) 94 END_2D 95 ! ! =============== 96 END DO ! End of slab 97 ! ! =============== 101 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use 102 & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm) & 103 & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) ) 104 END_2D 105 ! 106 END DO ! End of slab 107 ! 108 DEALLOCATE( zcur , zdiv ) 109 ! 110 CASE ( np_typ_sym ) !== Symmetric operator ==! 111 ! 112 ALLOCATE( zten(jpi,jpj) , zshe(jpi,jpj) ) 113 ! 114 DO jk = 1, jpkm1 ! Horizontal slab 115 ! 116 DO_2D( 0, 1, 0, 1 ) 117 ! ! shearing stress component (F-point) NB : ahmf has already been multiplied by fmask 118 zshe(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) & 119 & * ( e1f(ji-1,jj-1) * r1_e2f(ji-1,jj-1) & 120 & * ( pu(ji-1,jj ,jk) * r1_e1u(ji-1,jj ) - pu(ji-1,jj-1,jk) * r1_e1u(ji-1,jj-1) ) & 121 & + e2f(ji-1,jj-1) * r1_e1f(ji-1,jj-1) & 122 & * ( pv(ji ,jj-1,jk) * r1_e2v(ji ,jj-1) - pv(ji-1,jj-1,jk) * r1_e2v(ji-1,jj-1) ) ) 123 ! ! tension stress component (T-point) NB : ahmt has already been multiplied by tmask 124 zten(ji,jj) = ahmt(ji,jj,jk) & 125 & * ( e2t(ji,jj) * r1_e1t(ji,jj) & 126 & * ( pu(ji,jj,jk) * r1_e2u(ji,jj) - pu(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) & 127 & - e1t(ji,jj) * r1_e2t(ji,jj) & 128 & * ( pv(ji,jj,jk) * r1_e1v(ji,jj) - pv(ji,jj-1,jk) * r1_e1v(ji,jj-1) ) ) 129 END_2D 130 ! 131 DO_2D( 0, 0, 0, 0 ) 132 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & 133 & * ( ( zten(ji+1,jj ) * e2t(ji+1,jj )*e2t(ji+1,jj ) * e3t(ji+1,jj ,jk,Kmm) & 134 & - zten(ji ,jj ) * e2t(ji ,jj )*e2t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e2u(ji,jj) & 135 & + ( zshe(ji ,jj ) * e1f(ji ,jj )*e1f(ji ,jj ) * e3f(ji ,jj ,jk) & 136 & - zshe(ji ,jj-1) * e1f(ji ,jj-1)*e1f(ji ,jj-1) * e3f(ji ,jj-1,jk) ) * r1_e1u(ji,jj) ) 137 ! 138 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) & 139 & * ( ( zshe(ji ,jj ) * e2f(ji ,jj )*e2f(ji ,jj ) * e3f(ji ,jj ,jk) & 140 & - zshe(ji-1,jj ) * e2f(ji-1,jj )*e2f(ji-1,jj ) * e3f(ji-1,jj ,jk) ) * r1_e2v(ji,jj) & 141 & - ( zten(ji ,jj+1) * e1t(ji ,jj+1)*e1t(ji ,jj+1) * e3t(ji ,jj+1,jk,Kmm) & 142 & - zten(ji ,jj ) * e1t(ji ,jj )*e1t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e1v(ji,jj) ) 143 ! 144 END_2D 145 ! 146 END DO 147 ! 148 DEALLOCATE( zten , zshe ) 149 ! 150 END SELECT 98 151 ! 99 152 END SUBROUTINE dyn_ldf_lap -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynspg_ts.F90
r14037 r14062 295 295 ENDIF 296 296 ! 297 ! != Add atmospheric pressureforcing =!298 ! ! ------------------ ----------------!299 IF( ln_bt_fw ) THEN ! Add wind forcing297 ! != Add wind forcing =! 298 ! ! ------------------ ! 299 IF( ln_bt_fw ) THEN 300 300 DO_2D( 0, 0, 0, 0 ) 301 301 zu_frc(ji,jj) = zu_frc(ji,jj) + r1_rho0 * utau(ji,jj) * r1_hu(ji,jj,Kmm) … … 375 375 ! 376 376 IF( ln_linssh ) THEN ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) 377 zhup2_e(:,:) = hu (:,:,Kmm)378 zhvp2_e(:,:) = hv (:,:,Kmm)379 zhtp2_e(:,:) = ht (:,:)380 ENDIF 381 ! 382 IF (ln_bt_fw) THEN! FORWARD integration: start from NOW fields383 sshn_e(:,:) = pssh (:,:,Kmm)377 zhup2_e(:,:) = hu_0(:,:) 378 zhvp2_e(:,:) = hv_0(:,:) 379 zhtp2_e(:,:) = ht_0(:,:) 380 ENDIF 381 ! 382 IF( ln_bt_fw ) THEN ! FORWARD integration: start from NOW fields 383 sshn_e(:,:) = pssh (:,:,Kmm) 384 384 un_e (:,:) = puu_b(:,:,Kmm) 385 385 vn_e (:,:) = pvv_b(:,:,Kmm) … … 390 390 hvr_e (:,:) = r1_hv(:,:,Kmm) 391 391 ELSE ! CENTRED integration: start from BEFORE fields 392 sshn_e(:,:) = pssh (:,:,Kbb)392 sshn_e(:,:) = pssh (:,:,Kbb) 393 393 un_e (:,:) = puu_b(:,:,Kbb) 394 394 vn_e (:,:) = pvv_b(:,:,Kbb) … … 401 401 ! 402 402 ! Initialize sums: 403 puu_b 404 pvv_b 403 puu_b (:,:,Kaa) = 0._wp ! After barotropic velocities (or transport if flux form) 404 pvv_b (:,:,Kaa) = 0._wp 405 405 pssh (:,:,Kaa) = 0._wp ! Sum for after averaged sea level 406 un_adv(:,:) = 0._wp ! Sum for now transport issued from ts loop407 vn_adv(:,:) = 0._wp406 un_adv(:,:) = 0._wp ! Sum for now transport issued from ts loop 407 vn_adv(:,:) = 0._wp 408 408 ! 409 409 IF( ln_wd_dl ) THEN … … 464 464 ! 465 465 ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) 466 #if defined key_qcoTest_FluxForm 467 ! ! 'key_qcoTest_FluxForm' : simple ssh average 468 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 469 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj ) ) * ssumask(ji,jj) 470 END_2D 471 DO_2D( 1, 0, 1, 1 ) 472 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji ,jj+1) ) * ssvmask(ji,jj) 473 END_2D 474 #else 475 ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 466 476 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 467 477 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & … … 474 484 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 475 485 END_2D 486 #endif 476 487 ! 477 488 ENDIF … … 529 540 ! 530 541 ! Sea Surface Height at u-,v-points (vvl case only) 531 IF( .NOT.ln_linssh ) THEN 542 IF( .NOT.ln_linssh ) THEN 543 #if defined key_qcoTest_FluxForm 544 ! ! 'key_qcoTest_FluxForm' : simple ssh average 545 DO_2D( 1, 1, 1, 0 ) 546 zsshu_a(ji,jj) = r1_2 * ( ssha_e(ji,jj) + ssha_e(ji+1,jj ) ) * ssumask(ji,jj) 547 END_2D 548 DO_2D( 1, 0, 1, 1 ) 549 zsshv_a(ji,jj) = r1_2 * ( ssha_e(ji,jj) + ssha_e(ji ,jj+1) ) * ssvmask(ji,jj) 550 END_2D 551 #else 532 552 DO_2D( 0, 0, 0, 0 ) 533 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 534 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 535 & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) ) 536 zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 537 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 538 & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) ) 539 END_2D 540 ENDIF 553 zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 554 & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) ) * ssumask(ji,jj) 555 zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 556 & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) ) * ssvmask(ji,jj) 557 END_2D 558 #endif 559 ENDIF 541 560 ! 542 561 ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 … … 613 632 ! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 614 633 ! ! backward interpolated depth used in spg terms at jn+1/2 634 #if defined key_qcoTest_FluxForm 635 ! ! 'key_qcoTest_FluxForm' : simple ssh average 636 zhu_bck = hu_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj ) ) * ssumask(ji,jj) 637 zhv_bck = hv_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji ,jj+1) ) * ssvmask(ji,jj) 638 #else 615 639 zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 616 640 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 617 641 zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 618 642 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 643 #endif 619 644 ! ! inverse depth at jn+1 620 645 z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) … … 635 660 IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs 636 661 DO_2D( 0, 0, 0, 0 ) 637 ua_e(ji,jj) = ua_e(ji,jj) /(1.0 - rDt_e * zCdU_u(ji,jj) * hur_e(ji,jj))638 va_e(ji,jj) = va_e(ji,jj) /(1.0 - rDt_e * zCdU_v(ji,jj) * hvr_e(ji,jj))662 ua_e(ji,jj) = ua_e(ji,jj) / ( 1._wp - rDt_e * zCdU_u(ji,jj) * hur_e(ji,jj) ) 663 va_e(ji,jj) = va_e(ji,jj) / ( 1._wp - rDt_e * zCdU_v(ji,jj) * hvr_e(ji,jj) ) 639 664 END_2D 640 665 ENDIF 641 666 642 667 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 643 hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1)644 hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1))645 hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1)646 hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1))668 hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) 669 hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) 670 hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) 671 hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) 647 672 ENDIF 648 673 ! … … 732 757 ELSE 733 758 ! At this stage, pssh(:,:,:,Krhs) has been corrected: compute new depths at velocity points 759 #if defined key_qcoTest_FluxForm 760 ! ! 'key_qcoTest_FluxForm' : simple ssh average 734 761 DO_2D( 1, 0, 1, 0 ) 735 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 736 & * ( e1e2t(ji ,jj) * pssh(ji ,jj,Kaa) & 737 & + e1e2t(ji+1,jj) * pssh(ji+1,jj,Kaa) ) 738 zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 739 & * ( e1e2t(ji,jj ) * pssh(ji,jj ,Kaa) & 740 & + e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) 741 END_2D 762 zsshu_a(ji,jj) = r1_2 * ( pssh(ji,jj,Kaa) + pssh(ji+1,jj ,Kaa) ) * ssumask(ji,jj) 763 zsshv_a(ji,jj) = r1_2 * ( pssh(ji,jj,Kaa) + pssh(ji ,jj+1,Kaa) ) * ssvmask(ji,jj) 764 END_2D 765 #else 766 DO_2D( 1, 0, 1, 0 ) 767 zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * pssh(ji ,jj,Kaa) & 768 & + e1e2t(ji+1,jj) * pssh(ji+1,jj,Kaa) ) * ssumask(ji,jj) 769 zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * pssh(ji,jj ,Kaa) & 770 & + e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) * ssvmask(ji,jj) 771 END_2D 772 #endif 742 773 CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 743 774 ! 744 775 DO jk=1,jpkm1 745 puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + r1_hu(:,:,Kmm) * ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) * hu(:,:,Kbb) ) * r1_Dt_b 746 pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + r1_hv(:,:,Kmm) * ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) * hv(:,:,Kbb) ) * r1_Dt_b 776 puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + r1_hu(:,:,Kmm) & 777 & * ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) * hu(:,:,Kbb) ) * r1_Dt_b 778 pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + r1_hv(:,:,Kmm) & 779 & * ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) * hv(:,:,Kbb) ) * r1_Dt_b 747 780 END DO 748 781 ! Save barotropic velocities not transport: … … 888 921 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise 889 922 ! ! --------------- 890 IF( ln_rstart .AND. ln_bt_fw .AND. (.NOT.l_1st_euler)) THEN !* Read the restart file923 IF( ln_rstart .AND. ln_bt_fw .AND. .NOT.l_1st_euler ) THEN !* Read the restart file 891 924 CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._wp ) 892 925 CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._wp ) … … 1049 1082 !! although they should be updated in the variable volume case. Not a big approximation. 1050 1083 !! To remove this approximation, copy lines below inside barotropic loop 1051 !! and update depths at T- F points (ht and zhf resp.) at each barotropic time step1084 !! and update depths at T- points (ht) at each barotropic time step 1052 1085 !! 1053 1086 !! Compute zwz = f / ( height of the water colomn ) … … 1056 1089 INTEGER :: ji ,jj, jk ! dummy loop indices 1057 1090 REAL(wp) :: z1_ht 1058 REAL(wp), DIMENSION(jpi,jpj) :: zhf1059 1091 !!---------------------------------------------------------------------- 1060 1092 ! 1061 1093 SELECT CASE( nvor_scheme ) 1062 CASE( np_EEN ) != EEN scheme using e3f energy & enstrophy scheme1063 SELECT CASE( nn_e en_e3f )!* ff_f/e3 at F-point1094 CASE( np_EEN, np_ENE, np_ENS , np_MIX ) != schemes using the same e3f definition 1095 SELECT CASE( nn_e3f_typ ) !* ff_f/e3 at F-point 1064 1096 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 1065 DO_2D( 1, 0, 1, 0 )1066 zwz(ji,jj) = ( ht(ji ,jj+1) + ht(ji+1,jj+1) +&1067 & ht(ji ,jj ) + ht(ji+1,jj )) * 0.25_wp1097 DO_2D( 0, 0, 0, 0 ) 1098 zwz(ji,jj) = ( ht(ji,jj+1) + ht(ji+1,jj+1) & 1099 & + ht(ji,jj ) + ht(ji+1,jj ) ) * 0.25_wp 1068 1100 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1069 1101 END_2D 1070 1102 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 1071 DO_2D( 1, 0, 1, 0 )1072 zwz(ji,jj) = ( ht (ji ,jj+1) + ht(ji+1,jj+1) &1073 & + ht (ji ,jj ) + ht(ji+1,jj ) ) &1074 & / ( MAX( 1._wp, ssmask(ji,jj+1) + ssmask(ji+1,jj+1) &1075 & + ssmask(ji ,jj ) + ssmask(ji+1,jj )) )1103 DO_2D( 0, 0, 0, 0 ) 1104 zwz(ji,jj) = ( ht(ji,jj+1) + ht(ji+1,jj+1) & 1105 & + ht(ji,jj ) + ht(ji+1,jj ) ) & 1106 & / ( MAX(ssmask(ji,jj+1) + ssmask(ji+1,jj+1) & 1107 & + ssmask(ji,jj ) + ssmask(ji+1,jj ) , 1._wp ) ) 1076 1108 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1077 1109 END_2D 1078 1110 END SELECT 1079 1111 CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 1080 ! 1081 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1112 END SELECT 1113 ! 1114 SELECT CASE( nvor_scheme ) 1115 CASE( np_EEN ) 1116 ! 1117 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1082 1118 DO_2D( 0, 1, 0, 1 ) 1083 1119 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) … … 1087 1123 END_2D 1088 1124 ! 1089 CASE( np_EET ) != EEN scheme using e3t energy conserving scheme1090 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ;ftsw(1,:) = 0._wp1125 CASE( np_EET ) != EEN scheme using e3t energy conserving scheme 1126 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1091 1127 DO_2D( 0, 1, 0, 1 ) 1092 1128 z1_ht = ssmask(ji,jj) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) … … 1097 1133 END_2D 1098 1134 ! 1099 CASE( np_ENE, np_ENS , np_MIX ) != all other schemes (ENE, ENS, MIX) except ENT !1100 !1101 zwz(:,:) = 0._wp1102 zhf(:,:) = 0._wp1103 1104 !!gm assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed1105 !!gm A priori a better value should be something like :1106 !!gm zhf(i,j) = masked sum of ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1)1107 !!gm divided by the sum of the corresponding mask1108 !!gm1109 !!1110 IF( .NOT.ln_sco ) THEN1111 1112 !!gm agree the JC comment : this should be done in a much clear way1113 1114 ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case1115 ! Set it to zero for the time being1116 ! IF( rn_hmin < 0._wp ) THEN ; jk = - INT( rn_hmin ) ! from a nb of level1117 ! ELSE ; jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 ) ! from a depth1118 ! ENDIF1119 ! zhf(:,:) = gdepw_0(:,:,jk+1)1120 !1121 ELSE1122 !1123 !zhf(:,:) = hbatf(:,:)1124 DO_2D( 1, 0, 1, 0 )1125 zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) &1126 & + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) &1127 & / MAX( ssmask(ji,jj ) + ssmask(ji+1,jj ) &1128 & + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp )1129 END_2D1130 ENDIF1131 !1132 DO jj = 1, jpjm11133 zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1))1134 END DO1135 !1136 DO jk = 1, jpkm11137 DO jj = 1, jpjm11138 zhf(:,jj) = zhf(:,jj) + e3f(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk)1139 END DO1140 END DO1141 CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp )1142 ! JC: TBC. hf should be greater than 01143 DO_2D( 1, 1, 1, 1 )1144 IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj)1145 END_2D1146 zwz(:,:) = ff_f(:,:) * zwz(:,:)1147 1135 END SELECT 1148 1136 1149 1137 END SUBROUTINE dyn_cor_2d_init 1150 1151 1138 1152 1139 … … 1342 1329 END SUBROUTINE wad_spg 1343 1330 1344 1345 1331 1346 1332 SUBROUTINE dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b ,pvv_b, pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/dynvor.F90
r14037 r14062 21 21 !! - ! 2018-03 (G. Madec) add two new schemes (ln_dynvor_enT and ln_dynvor_eet) 22 22 !! - ! 2018-04 (G. Madec) add pre-computed gradient for metric term calculation 23 !! 4.x ! 2020-03 (G. Madec, A. Nasser) make ln_dynvor_msk truly efficient on relative vorticity 23 24 !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add vortex force trends (ln_vortex_force=T) 24 25 !!---------------------------------------------------------------------- … … 26 27 !!---------------------------------------------------------------------- 27 28 !! dyn_vor : Update the momentum trend with the vorticity trend 29 !! vor_enT : energy conserving scheme at T-pt (ln_dynvor_enT=T) 30 !! vor_ene : energy conserving scheme (ln_dynvor_ene=T) 28 31 !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T) 29 !! vor_ene : energy conserving scheme (ln_dynvor_ene=T)30 32 !! vor_een : energy and enstrophy conserving (ln_dynvor_een=T) 33 !! vor_eeT : energy conserving at T-pt (ln_dynvor_eeT=T) 31 34 !! dyn_vor_init : set and control of the different vorticity option 32 35 !!---------------------------------------------------------------------- … … 58 61 LOGICAL, PUBLIC :: ln_dynvor_eeT !: t-point energy conserving scheme (EET) 59 62 LOGICAL, PUBLIC :: ln_dynvor_een !: energy & enstrophy conserving scheme (EEN) 60 INTEGER, PUBLIC :: nn_een_e3f !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)61 63 LOGICAL, PUBLIC :: ln_dynvor_mix !: mixed scheme (MIX) 62 64 LOGICAL, PUBLIC :: ln_dynvor_msk !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) 65 INTEGER, PUBLIC :: nn_e3f_typ !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 63 66 64 67 INTEGER, PUBLIC :: nvor_scheme !: choice of the type of advection scheme … … 81 84 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation 82 85 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - - 83 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2v)/(2*e1e2f) used in F-point metric term calculation 84 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1u)/(2*e1e2f) - - - - 86 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2u)/(2*e1e2f) used in F-point metric term calculation 87 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - - 88 ! 89 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: e3f_0vor ! e3f used in EEN, ENE and ENS cases (key_qco only) 85 90 86 91 REAL(wp) :: r1_4 = 0.250_wp ! =1/4 … … 235 240 INTEGER :: ji, jj, jk ! dummy loop indices 236 241 REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars 237 REAL(wp), DIMENSION(jpi,jpj) 238 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwz! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined242 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwt ! 2D workspace 243 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined 239 244 !!---------------------------------------------------------------------- 240 245 ! … … 246 251 ! 247 252 ! 248 SELECT CASE( kvor ) !== volume weighted vorticity considered ==! 249 CASE ( np_RVO ) !* relative vorticity 250 DO jk = 1, jpkm1 ! Horizontal slab 253 SELECT CASE( kvor ) !== relative vorticity considered ==! 254 ! 255 CASE ( np_RVO , np_CRV ) !* relative vorticity at f-point is used 256 ALLOCATE( zwz(jpi,jpj,jpk) ) 257 DO jk = 1, jpkm1 ! Horizontal slab 251 258 DO_2D( 1, 0, 1, 0 ) 252 259 zwz(ji,jj,jk) = ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & 253 260 & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 254 261 END_2D 255 IF( ln_dynvor_msk ) THEN ! mask /unmaskrelative vorticity262 IF( ln_dynvor_msk ) THEN ! mask relative vorticity 256 263 DO_2D( 1, 0, 1, 0 ) 257 264 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) … … 259 266 ENDIF 260 267 END DO 261 262 268 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 263 264 CASE ( np_CRV ) !* Coriolis + relative vorticity 265 DO jk = 1, jpkm1 ! Horizontal slab 266 DO_2D( 1, 0, 1, 0 ) ! relative vorticity 267 zwz(ji,jj,jk) = ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & 268 & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 269 END_2D 270 IF( ln_dynvor_msk ) THEN ! mask/unmask relative vorticity 271 DO_2D( 1, 0, 1, 0 ) 272 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 273 END_2D 274 ENDIF 275 END DO 276 277 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 278 269 ! 279 270 END SELECT 280 271 281 272 ! ! =============== 282 273 DO jk = 1, jpkm1 ! Horizontal slab 283 !! ===============284 274 ! ! =============== 275 ! 285 276 SELECT CASE( kvor ) !== volume weighted vorticity considered ==! 277 ! 286 278 CASE ( np_COR ) !* Coriolis (planetary vorticity) 287 279 zwt(:,:) = ff_t(:,:) * e1e2t(:,:)*e3t(:,:,jk,Kmm) 288 280 CASE ( np_RVO ) !* relative vorticity 289 281 DO_2D( 0, 1, 0, 1 ) 290 zwt(ji,jj) = r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) &291 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )&292 & 282 zwt(ji,jj) = r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 283 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) & 284 & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 293 285 END_2D 294 286 CASE ( np_MET ) !* metric term 295 287 DO_2D( 0, 1, 0, 1 ) 296 zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) &297 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) &298 & 288 zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 289 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & 290 & * e3t(ji,jj,jk,Kmm) 299 291 END_2D 300 292 CASE ( np_CRV ) !* Coriolis + relative vorticity 301 293 DO_2D( 0, 1, 0, 1 ) 302 zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) &303 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) &304 & 294 zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 295 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) & 296 & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 305 297 END_2D 306 298 CASE ( np_CME ) !* Coriolis + metric 307 299 DO_2D( 0, 1, 0, 1 ) 308 zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) &309 & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) &310 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) &311 & 300 zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) & 301 & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 302 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & 303 & * e3t(ji,jj,jk,Kmm) 312 304 END_2D 313 305 CASE DEFAULT ! error 314 CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' 306 CALL ctl_stop('STOP','dyn_vor: wrong value for kvor') 315 307 END SELECT 316 308 ! … … 328 320 END DO ! End of slab 329 321 ! ! =============== 322 ! 323 SELECT CASE( kvor ) ! deallocate zwz if necessary 324 CASE ( np_RVO , np_CRV ) ; DEALLOCATE( zwz ) 325 END SELECT 326 ! 330 327 END SUBROUTINE vor_enT 331 328 … … 358 355 ! 359 356 INTEGER :: ji, jj, jk ! dummy loop indices 360 REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars357 REAL(wp) :: zx1, zy1, zx2, zy2, ze3f, zmsk ! local scalars 361 358 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz ! 2D workspace 362 359 !!---------------------------------------------------------------------- … … 380 377 & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 381 378 END_2D 379 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 380 DO_2D( 1, 0, 1, 0 ) 381 zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 382 END_2D 383 ENDIF 382 384 CASE ( np_MET ) !* metric term 383 385 DO_2D( 1, 0, 1, 0 ) … … 390 392 & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 391 393 END_2D 394 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term) 395 DO_2D( 1, 0, 1, 0 ) 396 zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 397 END_2D 398 ENDIF 392 399 CASE ( np_CME ) !* Coriolis + metric 393 400 DO_2D( 1, 0, 1, 0 ) … … 399 406 END SELECT 400 407 ! 401 IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! 402 DO_2D( 1, 0, 1, 0 ) 403 zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 404 END_2D 405 ENDIF 406 407 IF( ln_sco ) THEN 408 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 409 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 410 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 411 ELSE 412 zwx(:,:) = e2u(:,:) * pu(:,:,jk) 413 zwy(:,:) = e1v(:,:) * pv(:,:,jk) 414 ENDIF 408 #if defined key_qco 409 DO_2D( 1, 0, 1, 0 ) !== potential vorticity ==! (key_qco) 410 zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) 411 END_2D 412 #else 413 SELECT CASE( nn_e3f_typ ) !== potential vorticity ==! 414 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 415 DO_2D( 1, 0, 1, 0 ) 416 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 417 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 418 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 419 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 420 IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f 421 ELSE ; zwz(ji,jj) = 0._wp 422 ENDIF 423 END_2D 424 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 425 DO_2D( 1, 0, 1, 0 ) 426 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 427 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 428 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 429 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 430 zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 431 & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) 432 IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f 433 ELSE ; zwz(ji,jj) = 0._wp 434 ENDIF 435 END_2D 436 END SELECT 437 #endif 438 ! !== horizontal fluxes ==! 439 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 440 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 441 ! 415 442 ! !== compute and add the vorticity term trend =! 416 443 DO_2D( 0, 0, 0, 0 ) … … 455 482 ! 456 483 INTEGER :: ji, jj, jk ! dummy loop indices 457 REAL(wp) :: zuav, zvau ! local scalars484 REAL(wp) :: zuav, zvau, ze3f, zmsk ! local scalars 458 485 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz, zww ! 2D workspace 459 486 !!---------------------------------------------------------------------- … … 476 503 & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 477 504 END_2D 505 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 506 DO_2D( 1, 0, 1, 0 ) 507 zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 508 END_2D 509 ENDIF 478 510 CASE ( np_MET ) !* metric term 479 511 DO_2D( 1, 0, 1, 0 ) … … 486 518 & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 487 519 END_2D 520 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term) 521 DO_2D( 1, 0, 1, 0 ) 522 zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 523 END_2D 524 ENDIF 488 525 CASE ( np_CME ) !* Coriolis + metric 489 526 DO_2D( 1, 0, 1, 0 ) … … 495 532 END SELECT 496 533 ! 497 IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! 498 DO_2D( 1, 0, 1, 0 ) 499 zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 500 END_2D 501 ENDIF 502 ! 503 IF( ln_sco ) THEN !== horizontal fluxes ==! 504 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 505 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 506 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 507 ELSE 508 zwx(:,:) = e2u(:,:) * pu(:,:,jk) 509 zwy(:,:) = e1v(:,:) * pv(:,:,jk) 510 ENDIF 534 ! 535 #if defined key_qco 536 DO_2D( 1, 0, 1, 0 ) !== potential vorticity ==! (key_qco) 537 zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) 538 END_2D 539 #else 540 SELECT CASE( nn_e3f_typ ) !== potential vorticity ==! 541 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 542 DO_2D( 1, 0, 1, 0 ) 543 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 544 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 545 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 546 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 547 IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f 548 ELSE ; zwz(ji,jj) = 0._wp 549 ENDIF 550 END_2D 551 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 552 DO_2D( 1, 0, 1, 0 ) 553 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 554 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 555 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 556 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 557 zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 558 & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) 559 IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f 560 ELSE ; zwz(ji,jj) = 0._wp 561 ENDIF 562 END_2D 563 END SELECT 564 #endif 565 ! !== horizontal fluxes ==! 566 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 567 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 568 ! 511 569 ! !== compute and add the vorticity term trend =! 512 570 DO_2D( 0, 0, 0, 0 ) … … 566 624 ! ! =============== 567 625 ! 568 SELECT CASE( nn_een_e3f ) ! == reciprocal of e3 at F-point 626 #if defined key_qco 627 DO_2D( 1, 0, 1, 0 ) ! == reciprocal of e3 at F-point (key_qco) 628 z1_e3f(ji,jj) = 1._wp / e3f_vor(ji,jj,jk) 629 END_2D 630 #else 631 SELECT CASE( nn_e3f_typ ) ! == reciprocal of e3 at F-point 569 632 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 570 633 DO_2D( 1, 0, 1, 0 ) … … 590 653 END_2D 591 654 END SELECT 655 #endif 592 656 ! 593 657 SELECT CASE( kvor ) !== vorticity considered ==! 658 ! 594 659 CASE ( np_COR ) !* Coriolis (planetary vorticity) 595 660 DO_2D( 1, 0, 1, 0 ) … … 601 666 & - e1u(ji ,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj) 602 667 END_2D 668 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 669 DO_2D( 1, 0, 1, 0 ) 670 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 671 END_2D 672 ENDIF 603 673 CASE ( np_MET ) !* metric term 604 674 DO_2D( 1, 0, 1, 0 ) … … 612 682 & * r1_e1e2f(ji,jj) ) * z1_e3f(ji,jj) 613 683 END_2D 684 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 685 DO_2D( 1, 0, 1, 0 ) 686 zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 687 END_2D 688 ENDIF 614 689 CASE ( np_CME ) !* Coriolis + metric 615 690 DO_2D( 1, 0, 1, 0 ) … … 620 695 CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) 621 696 END SELECT 622 ! 623 IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! 624 DO_2D( 1, 0, 1, 0 ) 625 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 626 END_2D 627 ENDIF 697 ! ! =============== 628 698 END DO ! End of slab 629 ! 699 ! ! =============== 700 ! 630 701 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 631 702 ! 703 ! ! =============== 632 704 DO jk = 1, jpkm1 ! Horizontal slab 705 ! ! =============== 633 706 ! 634 707 ! !== horizontal fluxes ==! 635 708 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 636 709 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 637 710 ! 638 711 ! !== compute and add the vorticity term trend =! 639 jj = 2 640 ztne(1,:) = 0 ; ztnw(1,:) = 0 ; ztse(1,:) = 0 ; ztsw(1,:) = 0 641 DO ji = 2, jpi ! split in 2 parts due to vector opt. 642 ztne(ji,jj) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) 643 ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) 644 ztse(ji,jj) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) 645 ztsw(ji,jj) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) 646 END DO 647 DO jj = 3, jpj 648 DO ji = 2, jpi ! vector opt. ok because we start at jj = 3 649 ztne(ji,jj) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) 650 ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) 651 ztse(ji,jj) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) 652 ztsw(ji,jj) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) 653 END DO 654 END DO 712 DO_2D( 0, 1, 0, 1 ) 713 ztne(ji,jj) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) 714 ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) 715 ztse(ji,jj) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) 716 ztsw(ji,jj) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) 717 END_2D 718 ! 655 719 DO_2D( 0, 0, 0, 0 ) 656 720 zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) & … … 667 731 668 732 669 670 733 SUBROUTINE vor_eeT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) 671 734 !!---------------------------------------------------------------------- … … 685 748 !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 686 749 !!---------------------------------------------------------------------- 687 INTEGER , INTENT(in ) :: kt ! ocean time-step index750 INTEGER , INTENT(in ) :: kt ! ocean time-step index 688 751 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 689 INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric690 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities691 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs 752 INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric 753 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities 754 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend 692 755 ! 693 756 INTEGER :: ji, jj, jk ! dummy loop indices … … 702 765 IF( kt == nit000 ) THEN 703 766 IF(lwp) WRITE(numout,*) 704 IF(lwp) WRITE(numout,*) 'dyn:vor_ee n: vorticity term: energy and enstrophy conserving scheme'767 IF(lwp) WRITE(numout,*) 'dyn:vor_eeT : vorticity term: energy and enstrophy conserving scheme' 705 768 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 706 769 ENDIF … … 722 785 & * r1_e1e2f(ji,jj) 723 786 END_2D 787 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 788 DO_2D( 1, 0, 1, 0 ) 789 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 790 END_2D 791 ENDIF 724 792 CASE ( np_MET ) !* metric term 725 793 DO_2D( 1, 0, 1, 0 ) … … 733 801 & * r1_e1e2f(ji,jj) ) 734 802 END_2D 803 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 804 DO_2D( 1, 0, 1, 0 ) 805 zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 806 END_2D 807 ENDIF 735 808 CASE ( np_CME ) !* Coriolis + metric 736 809 DO_2D( 1, 0, 1, 0 ) … … 742 815 END SELECT 743 816 ! 744 IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! 745 DO_2D( 1, 0, 1, 0 ) 746 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 747 END_2D 748 ENDIF 749 END DO 817 ! ! =============== 818 END DO ! End of slab 819 ! ! =============== 750 820 ! 751 821 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 752 822 ! 823 ! ! =============== 753 824 DO jk = 1, jpkm1 ! Horizontal slab 754 755 ! !== horizontal fluxes ==! 825 ! ! =============== 826 ! 827 ! !== horizontal fluxes ==! 756 828 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 757 829 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 758 830 ! 759 831 ! !== compute and add the vorticity term trend =! 760 jj = 2 761 ztne(1,:) = 0 ; ztnw(1,:) = 0 ; ztse(1,:) = 0 ; ztsw(1,:) = 0 762 DO ji = 2, jpi ! split in 2 parts due to vector opt. 763 z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 764 ztne(ji,jj) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t 765 ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t 766 ztse(ji,jj) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t 767 ztsw(ji,jj) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t 768 END DO 769 DO jj = 3, jpj 770 DO ji = 2, jpi ! vector opt. ok because we start at jj = 3 771 z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 772 ztne(ji,jj) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t 773 ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t 774 ztse(ji,jj) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t 775 ztsw(ji,jj) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t 776 END DO 777 END DO 832 DO_2D( 0, 1, 0, 1 ) 833 z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 834 ztne(ji,jj) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t 835 ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t 836 ztse(ji,jj) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t 837 ztsw(ji,jj) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t 838 END_2D 839 ! 778 840 DO_2D( 0, 0, 0, 0 ) 779 841 zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) & … … 799 861 INTEGER :: ji, jj, jk ! dummy loop indices 800 862 INTEGER :: ioptio, ios ! local integer 863 REAL(wp) :: zmsk ! local scalars 801 864 !! 802 865 NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT, & 803 & ln_dynvor_een, nn_e en_e3f, ln_dynvor_mix, ln_dynvor_msk866 & ln_dynvor_een, nn_e3f_typ , ln_dynvor_mix, ln_dynvor_msk 804 867 !!---------------------------------------------------------------------- 805 868 ! … … 823 886 WRITE(numout,*) ' energy conserving scheme (een using e3t) ln_dynvor_eeT = ', ln_dynvor_eeT 824 887 WRITE(numout,*) ' enstrophy and energy conserving scheme ln_dynvor_een = ', ln_dynvor_een 825 WRITE(numout,*) ' e3f = averaging /4 (=0) or /sum(tmask) (=1) nn_e en_e3f = ', nn_een_e3f888 WRITE(numout,*) ' e3f = averaging /4 (=0) or /sum(tmask) (=1) nn_e3f_typ = ', nn_e3f_typ 826 889 WRITE(numout,*) ' mixed enstrophy/energy conserving scheme ln_dynvor_mix = ', ln_dynvor_mix 827 890 WRITE(numout,*) ' masked (=T) or unmasked(=F) vorticity ln_dynvor_msk = ', ln_dynvor_msk 828 891 ENDIF 829 830 IF( ln_dynvor_msk ) CALL ctl_stop( 'dyn_vor_init: masked vorticity is not currently not available')831 892 832 893 !!gm this should be removed when choosing a unique strategy for fmask at the coast … … 891 952 ! 892 953 END SELECT 893 954 #if defined key_qco 955 SELECT CASE( nvor_scheme ) ! qco case: pre-computed a specific e3f_0 for some vorticity schemes 956 CASE( np_ENS , np_ENE , np_EEN , np_MIX ) 957 ! 958 ALLOCATE( e3f_0vor(jpi,jpj,jpk) ) 959 ! 960 SELECT CASE( nn_e3f_typ ) 961 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 962 DO_3D( 0, 0, 0, 0, 1, jpk ) 963 e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & 964 & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 965 & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) & 966 & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) * 0.25_wp 967 END_3D 968 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 969 DO_3D( 0, 0, 0, 0, 1, jpk ) 970 zmsk = (tmask(ji,jj+1,jk) +tmask(ji+1,jj+1,jk) & 971 & + tmask(ji,jj ,jk) +tmask(ji+1,jj ,jk) ) 972 ! 973 IF( zmsk /= 0._wp ) THEN 974 e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & 975 & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 976 & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) & 977 & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) / zmsk 978 ENDIF 979 END_3D 980 END SELECT 981 ! 982 CALL lbc_lnk( 'dynvor', e3f_0vor, 'F', 1._wp ) 983 ! ! insure e3f_0vor /= 0 984 WHERE( e3f_0vor(:,:,:) == 0._wp ) e3f_0vor(:,:,:) = e3f_0(:,:,:) 985 ! 986 END SELECT 987 ! 988 #endif 894 989 IF(lwp) THEN ! Print the choice 895 990 WRITE(numout,*) … … 898 993 CASE( np_ENE ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at F-points) (ENE)' 899 994 CASE( np_ENT ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at T-points) (ENT)' 995 IF( ln_dynadv_vec ) CALL ctl_warn('dyn_vor_init: ENT scheme may not work in vector form') 900 996 CASE( np_EET ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (EEN scheme using e3t) (EET)' 901 997 CASE( np_EEN ) ; WRITE(numout,*) ' ==>>> energy and enstrophy conserving scheme (EEN)' -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DYN/sshwzv.F90
r14037 r14062 6 6 !! History : 3.1 ! 2009-02 (G. Madec, M. Leclair) Original code 7 7 !! 3.3 ! 2010-04 (M. Leclair, G. Madec) modified LF-RA 8 !! - ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 9 !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module 10 !! 3.3 ! 2011-10 (M. Leclair) split former ssh_wzv routine and remove all vvl related work 11 !! 4.0 ! 2018-12 (A. Coward) add mixed implicit/explicit advection 12 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename ssh_nxt -> ssh_atf. Now only does time filtering. 8 !! - ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 9 !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module 10 !! 3.3 ! 2011-10 (M. Leclair) split former ssh_wzv routine and remove all vvl related work 11 !! 4.0 ! 2018-12 (A. Coward) add mixed implicit/explicit advection 12 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename ssh_nxt -> ssh_atf. Now only does time filtering. 13 !! - ! 2020-08 (S. Techene, G. Madec) add here ssh initiatlisation 13 14 !!---------------------------------------------------------------------- 14 15 … … 17 18 !! ssh_atf : time filter the ssh arrays 18 19 !! wzv : compute now vertical velocity 20 !! ssh_init_rst : ssh set from restart or domcfg.nc file or usr_def_istat_ssh 19 21 !!---------------------------------------------------------------------- 20 22 USE oce ! ocean dynamics and tracers variables … … 40 42 USE timing ! Timing 41 43 USE wet_dry ! Wetting/Drying flux limiting 42 44 USE usrdef_istate, ONLY : usr_def_istate_ssh ! user defined ssh initial state 45 43 46 IMPLICIT NONE 44 47 PRIVATE 45 48 46 PUBLIC ssh_nxt ! called by step.F90 47 PUBLIC wzv ! called by step.F90 48 PUBLIC wAimp ! called by step.F90 49 PUBLIC ssh_atf ! called by step.F90 49 PUBLIC ssh_nxt ! called by step.F90 50 PUBLIC wzv ! called by step.F90 51 PUBLIC wAimp ! called by step.F90 52 PUBLIC ssh_atf ! called by step.F90 53 PUBLIC ssh_init_rst ! called by domain.F90 50 54 51 55 !! * Substitutions 52 56 # include "do_loop_substitute.h90" 53 57 # include "domzgr_substitute.h90" 54 55 58 !!---------------------------------------------------------------------- 56 59 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 299 302 ! ! filtered "now" field 300 303 pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) 304 ! 301 305 IF( .NOT.ln_linssh ) THEN ! "now" <-- with forcing removed 302 306 zcoef = rn_atfp * rn_Dt * r1_rho0 … … 307 311 308 312 ! ice sheet coupling 309 IF ( ln_isf .AND. ln_isfcpl .AND. kt == nit000+1) pssh(:,:,Kbb) = pssh(:,:,Kbb) - rn_atfp * rn_Dt * ( risfcpl_ssh(:,:) - 0.0 ) * ssmask(:,:) 313 IF( ln_isf .AND. ln_isfcpl .AND. kt == nit000+1 ) & 314 & pssh(:,:,Kbb) = pssh(:,:,Kbb) - rn_atfp * rn_Dt * ( risfcpl_ssh(:,:) - 0.0 ) * ssmask(:,:) 310 315 311 316 ENDIF 312 317 ENDIF 313 318 ! 314 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pssh(:,:,Kmm), clinfo1=' pssh(:,:,Kmm) -: ', mask1=tmask )319 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pssh(:,:,Kmm), clinfo1=' atf - pssh(:,:,Kmm): ', mask1=tmask ) 315 320 ! 316 321 IF( ln_timing ) CALL timing_stop('ssh_atf') … … 431 436 ! 432 437 END SUBROUTINE wAimp 438 439 440 SUBROUTINE ssh_init_rst( Kbb, Kmm, Kaa ) 441 !!--------------------------------------------------------------------- 442 !! *** ROUTINE ssh_init_rst *** 443 !! 444 !! ** Purpose : ssh initialization of the sea surface height (ssh) 445 !! 446 !! ** Method : set ssh from restart or read configuration, or user_def 447 !! * ln_rstart = T 448 !! USE of IOM library to read ssh in the restart file 449 !! Leap-Frog: Kbb and Kmm are read except for l_1st_euler=T 450 !! 451 !! * otherwise 452 !! call user defined ssh or 453 !! set to -ssh_ref in wet and drying case with domcfg.nc 454 !! 455 !! NB: ssh_b/n are written by restart.F90 456 !!---------------------------------------------------------------------- 457 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 458 ! 459 INTEGER :: ji, jj, jk 460 !!---------------------------------------------------------------------- 461 ! 462 IF(lwp) THEN 463 WRITE(numout,*) 464 WRITE(numout,*) 'ssh_init_rst : ssh initialization' 465 WRITE(numout,*) '~~~~~~~~~~~~ ' 466 ENDIF 467 ! 468 ! !=============================! 469 IF( ln_rstart ) THEN !== Read the restart file ==! 470 ! !=============================! 471 ! 472 ! !* Read ssh at Kmm 473 IF(lwp) WRITE(numout,*) 474 IF(lwp) WRITE(numout,*) ' Kmm sea surface height read in the restart file' 475 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 476 ! 477 IF( l_1st_euler ) THEN !* Euler at first time-step 478 IF(lwp) WRITE(numout,*) 479 IF(lwp) WRITE(numout,*) ' Euler first time step : ssh(Kbb) = ssh(Kmm)' 480 ssh(:,:,Kbb) = ssh(:,:,Kmm) 481 ! 482 ELSE !* read ssh at Kbb 483 IF(lwp) WRITE(numout,*) 484 IF(lwp) WRITE(numout,*) ' Kbb sea surface height read in the restart file' 485 CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 486 ENDIF 487 ! !============================! 488 ELSE !== Initialize at "rest" ==! 489 ! !============================! 490 ! 491 IF(lwp) WRITE(numout,*) 492 IF(lwp) WRITE(numout,*) ' initialization at rest' 493 ! 494 IF( ll_wd ) THEN !* wet and dry 495 ! 496 IF( ln_read_cfg ) THEN ! read configuration : ssh_ref is read in domain_cfg file 497 !!st why ssh is not masked : i.e. ssh(:,:,Kmm) = -ssh_ref*ssmask(:,:), 498 !!st since at the 1st time step lbclnk will be applied on ssh at Kaa but not initially at Kbb and Kmm 499 ssh(:,:,Kbb) = -ssh_ref 500 ! 501 DO_2D( 1, 1, 1, 1 ) 502 IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth 503 ssh(ji,jj,Kbb) = rn_wdmin1 - ht_0(ji,jj) 504 ENDIF 505 END_2D 506 ELSE ! user define configuration case 507 CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) 508 ENDIF 509 ! 510 ELSE !* user defined configuration 511 CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) 512 ! 513 ENDIF 514 ! 515 ssh(:,:,Kmm) = ssh(:,:,Kbb) !* set now values from to before ones 516 ssh(:,:,Kaa) = 0._wp 517 ENDIF 518 ! 519 END SUBROUTINE ssh_init_rst 520 433 521 !!====================================================================== 434 522 END MODULE sshwzv -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/IOM/iom.F90
r14044 r14062 174 174 CALL set_grid( "V", glamv, gphiv, .FALSE., .FALSE. ) 175 175 CALL set_grid( "W", glamt, gphit, .FALSE., .FALSE. ) 176 CALL set_grid( "F", glamf, gphif, .FALSE., .FALSE. ) 176 177 CALL set_grid_znl( gphit ) 177 178 ! … … 180 181 CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp)) 181 182 CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp)) 182 CALL iom_set_domain_attr("grid_W", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 183 CALL iom_set_domain_attr("grid_W", area = REAL( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 184 CALL iom_set_domain_attr("grid_F", area = real( e1e2f(Nis0:Nie0, Njs0:Nje0), dp)) 183 185 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 184 186 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) 185 187 CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv ) 186 188 CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit ) 189 CALL set_grid_bounds( "F", glamt, gphit, glamf, gphif ) 187 190 ENDIF 188 191 ENDIF … … 191 194 CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 192 195 ! 193 CALL set_grid( "T", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 194 CALL set_grid( "U", glamu_crs, gphiu_crs, .FALSE., .FALSE. ) 195 CALL set_grid( "V", glamv_crs, gphiv_crs, .FALSE., .FALSE. ) 196 CALL set_grid( "W", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 196 CALL set_grid( "T", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 197 CALL set_grid( "U", glamu_crs, gphiu_crs, .FALSE., .FALSE. ) 198 CALL set_grid( "V", glamv_crs, gphiv_crs, .FALSE., .FALSE. ) 199 CALL set_grid( "W", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 197 200 CALL set_grid_znl( gphit_crs ) 198 201 ! … … 217 220 CALL iom_set_axis_attr( "depthv", paxis = gdept_1d ) 218 221 CALL iom_set_axis_attr( "depthw", paxis = gdepw_1d ) 222 CALL iom_set_axis_attr( "depthf", paxis = gdept_1d ) 219 223 220 224 ! ABL … … 238 242 CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 239 243 CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 244 CALL iom_set_axis_attr( "depthf", bounds=zw_bnds ) 240 245 241 246 ! ABL -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/IOM/restart.F90
r14037 r14062 11 11 !! 3.7 ! 2014-01 (G. Madec) suppression of curl and hdiv from the restart 12 12 !! - ! 2014-12 (G. Madec) remove KPP scheme 13 !! 4.1 ! 2020-11 (S. Techene, G. Madec) move ssh initiatlisation in DYN/sshwzv:ssh_init_rst 13 14 !!---------------------------------------------------------------------- 14 15 … … 139 140 !! ** Method : Write in numrow when kt == nitrst in NetCDF 140 141 !! file, save fields which are necessary for restart 142 !! 143 !! NB: ssh is written here (rst_write) 144 !! but is read or set in DYN/sshwzv:shh_init_rst 141 145 !!---------------------------------------------------------------------- 142 146 INTEGER, INTENT(in) :: kt ! ocean time-step … … 233 237 !! *** ROUTINE rst_read *** 234 238 !! 235 !! ** Purpose : Read files for NetCDF restart 236 !! 237 !! ** Method : Read in restart.nc file fields which are necessary for restart 239 !! ** Purpose : Read velocity and T-S fields in the restart file 240 !! 241 !! ** Method : Read in restart.nc fields which are necessary for restart 242 !! 243 !! NB: restart file openned in DOM/domain.F90:dom_init 244 !! before field in restart tested in DOM/domain.F90:dom_init 245 !! (sshb) 246 !! 247 !! NB: ssh is read or set in DYN/sshwzv:shh_init_rst 248 !! but is written in IOM/restart:rst_write 238 249 !!---------------------------------------------------------------------- 239 250 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices 240 REAL(wp) :: zrdt241 251 INTEGER :: jk 242 252 REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d 243 253 !!---------------------------------------------------------------------- 244 245 CALL rst_read_open ! open restart for reading (if not already opened) 246 247 ! Check dynamics and tracer time-step consistency and force Euler restart if changed 248 IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN 249 CALL iom_get( numror, 'rdt', zrdt ) 250 IF( zrdt /= rn_Dt ) THEN 251 IF(lwp) WRITE( numout,*) 252 IF(lwp) WRITE( numout,*) 'rst_read: rdt not equal to the read one' 253 IF(lwp) WRITE( numout,*) 254 IF(lwp) WRITE( numout,*) ' ==>>> forced euler first time-step' 255 l_1st_euler = .TRUE. 256 ENDIF 257 ENDIF 258 254 ! 259 255 IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables 260 261 ! Diurnal DSST262 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst )256 ! 257 ! !* Diurnal DSST 258 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst ) 263 259 IF ( ln_diurnal_only ) THEN 264 260 IF(lwp) WRITE( numout, * ) & … … 269 265 RETURN 270 266 ENDIF 271 272 IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 273 ! before fields 267 ! 268 ! !* Read Kmm fields 269 IF(lwp) WRITE(numout,*) ' Kmm u, v and T-S fields read in the restart file' 270 CALL iom_get( numror, jpdom_auto, 'un' , uu(:,:,: ,Kmm), cd_type = 'U', psgn = -1._wp ) 271 CALL iom_get( numror, jpdom_auto, 'vn' , vv(:,:,: ,Kmm), cd_type = 'V', psgn = -1._wp ) 272 CALL iom_get( numror, jpdom_auto, 'tn' , ts(:,:,:,jp_tem,Kmm) ) 273 CALL iom_get( numror, jpdom_auto, 'sn' , ts(:,:,:,jp_sal,Kmm) ) 274 ! 275 IF( l_1st_euler ) THEN !* Euler restart 276 IF(lwp) WRITE(numout,*) ' Kbb u, v and T-S fields set to Kmm values' 277 ts(:,:,:,:,Kbb) = ts(:,:,:,:,Kmm) ! all before fields set to now values 278 uu(:,:,: ,Kbb) = uu(:,:,: ,Kmm) 279 vv(:,:,: ,Kbb) = vv(:,:,: ,Kmm) 280 ELSE !* Leap frog restart 281 IF(lwp) WRITE(numout,*) ' Kbb u, v and T-S fields read in the restart file' 274 282 CALL iom_get( numror, jpdom_auto, 'ub' , uu(:,:,: ,Kbb), cd_type = 'U', psgn = -1._wp ) 275 283 CALL iom_get( numror, jpdom_auto, 'vb' , vv(:,:,: ,Kbb), cd_type = 'V', psgn = -1._wp ) 276 284 CALL iom_get( numror, jpdom_auto, 'tb' , ts(:,:,:,jp_tem,Kbb) ) 277 285 CALL iom_get( numror, jpdom_auto, 'sb' , ts(:,:,:,jp_sal,Kbb) ) 278 CALL iom_get( numror, jpdom_auto, 'sshb' ,ssh(:,: ,Kbb) ) 279 ELSE 280 l_1st_euler = .TRUE. ! before field not found, forced euler 1st time-step 281 ENDIF 282 ! 283 ! now fields 284 CALL iom_get( numror, jpdom_auto, 'un' , uu(:,:,: ,Kmm), cd_type = 'U', psgn = -1._wp ) 285 CALL iom_get( numror, jpdom_auto, 'vn' , vv(:,:,: ,Kmm), cd_type = 'V', psgn = -1._wp ) 286 CALL iom_get( numror, jpdom_auto, 'tn' , ts(:,:,:,jp_tem,Kmm) ) 287 CALL iom_get( numror, jpdom_auto, 'sn' , ts(:,:,:,jp_sal,Kmm) ) 288 CALL iom_get( numror, jpdom_auto, 'sshn' ,ssh(:,: ,Kmm) ) 286 ENDIF 287 ! 289 288 IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 290 289 CALL iom_get( numror, jpdom_auto, 'rhop' , rhop ) ! now potential density … … 293 292 ENDIF 294 293 ! 295 IF( l_1st_euler ) THEN ! Euler restart296 ts (:,:,:,:,Kbb) = ts (:,:,:,:,Kmm) ! all before fields set to now values297 uu (:,:,: ,Kbb) = uu (:,:,: ,Kmm)298 vv (:,:,: ,Kbb) = vv (:,:,: ,Kmm)299 ssh (:,: ,Kbb) = ssh (:,: ,Kmm)300 ENDIF301 !302 294 END SUBROUTINE rst_read 303 295 -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ISF/isfcpl.F90
r14037 r14062 10 10 11 11 !!---------------------------------------------------------------------- 12 !! isfrst : read/write iceshelf variables in/from restart12 !! isfrst : read/write iceshelf variables in/from restart 13 13 !!---------------------------------------------------------------------- 14 USE isf_oce ! ice shelf variable 14 USE oce ! ocean dynamics and tracers 15 #if defined key_qco 16 USE domqco , ONLY : dom_qco_zgr ! vertical scale factor interpolation 17 #else 18 USE domvvl , ONLY : dom_vvl_zgr ! vertical scale factor interpolation 19 #endif 20 USE domutl , ONLY : dom_ngb ! find the closest grid point from a given lon/lat position 21 USE isf_oce ! ice shelf variable 15 22 USE isfutils, ONLY : debug 16 USE lib_mpp , ONLY: mpp_sum, mpp_max ! mpp routine17 #if ! defined key_qco18 USE domvvl , ONLY: dom_vvl_zgr ! vertical scale factor interpolation19 #else20 USE domqco , ONLY: dom_qco_zgr ! vertical scale factor interpolation21 #endif22 USE domutl , ONLY: dom_ngb ! find the closest grid point from a given lon/lat position23 23 ! 24 USE oce ! ocean dynamics and tracers25 24 USE in_out_manager ! I/O manager 26 25 USE iom ! I/O library 26 USE lib_mpp , ONLY : mpp_sum, mpp_max ! mpp routine 27 27 ! 28 28 IMPLICIT NONE … … 34 34 35 35 TYPE isfcons 36 INTEGER :: ii ! i global37 INTEGER :: jj ! j global38 INTEGER :: kk ! k level39 REAL(wp):: dvol ! volume increment40 REAL(wp):: dsal ! salt increment41 REAL(wp):: dtem ! heat increment42 REAL(wp):: lon ! lon43 REAL(wp):: lat ! lat44 INTEGER :: ngb ! 0/1 (valid location or not (ie on halo or no neigbourg))36 INTEGER :: ii ! i global 37 INTEGER :: jj ! j global 38 INTEGER :: kk ! k level 39 REAL(wp):: dvol ! volume increment 40 REAL(wp):: dsal ! salt increment 41 REAL(wp):: dtem ! heat increment 42 REAL(wp):: lon ! lon 43 REAL(wp):: lat ! lat 44 INTEGER :: ngb ! 0/1 (valid location or not (ie on halo or no neigbourg)) 45 45 END TYPE 46 46 ! … … 121 121 #endif 122 122 END SUBROUTINE isfcpl_init 123 ! 124 SUBROUTINE isfcpl_rst_write(kt, Kmm) 123 124 125 SUBROUTINE isfcpl_rst_write( kt, Kmm ) 125 126 !!--------------------------------------------------------------------- 126 127 !! *** ROUTINE iscpl_rst_write *** … … 133 134 !!---------------------------------------------------------------------- 134 135 INTEGER :: jk ! loop index 135 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! e3t , e3u, e3v !!st patch to usesubstitution136 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! for qco substitution 136 137 !!---------------------------------------------------------------------- 137 138 ! … … 153 154 END SUBROUTINE isfcpl_rst_write 154 155 156 155 157 SUBROUTINE isfcpl_ssh(Kbb, Kmm, Kaa) 156 158 !!---------------------------------------------------------------------- … … 184 186 zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:) 185 187 DO_2D( 0, 0, 0, 0 ) 186 jip1=ji+1 ; jim1=ji-1;187 jjp1=jj+1 ; jjm1=jj-1;188 jip1=ji+1 ; jim1=ji-1 189 jjp1=jj+1 ; jjm1=jj-1 188 190 ! 189 191 zsummsk = zssmask0(jip1,jj) + zssmask0(jim1,jj) + zssmask0(ji,jjp1) + zssmask0(ji,jjm1) … … 191 193 IF (zdssmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp) THEN 192 194 ssh(ji,jj,Kmm)=( zssh(jip1,jj)*zssmask0(jip1,jj) & 193 & + zssh(jim1,jj)*zssmask0(jim1,jj) &194 & + zssh(ji,jjp1)*zssmask0(ji,jjp1) &195 & + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk195 & + zssh(jim1,jj)*zssmask0(jim1,jj) & 196 & + zssh(ji,jjp1)*zssmask0(ji,jjp1) & 197 & + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk 196 198 zssmask_b(ji,jj) = 1._wp 197 199 ENDIF … … 222 224 CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 223 225 #else 224 CALL dom_qco_zgr(Kbb, Kmm , Kaa)226 CALL dom_qco_zgr(Kbb, Kmm) 225 227 #endif 226 228 ! 227 229 END SUBROUTINE isfcpl_ssh 228 230 231 229 232 SUBROUTINE isfcpl_tra(Kmm) 230 233 !!---------------------------------------------------------------------- … … 375 378 ! 376 379 END SUBROUTINE isfcpl_tra 380 377 381 378 382 SUBROUTINE isfcpl_vol(Kmm) … … 466 470 risfcpl_ssh(:,:) = risfcpl_ssh(:,:) + risfcpl_vol(:,:,jk) * r1_e1e2t(:,:) 467 471 END DO 468 472 ! 469 473 END SUBROUTINE isfcpl_vol 470 474 475 471 476 SUBROUTINE isfcpl_cons(Kmm) 472 477 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ISF/isfdynatf.F90
r13237 r14062 15 15 USE phycst , ONLY: r1_rho0 ! physical constant 16 16 USE dom_oce ! time and space domain 17 USE oce, ONLY : ssh ! sea-surface height !!st needed forsubstitution17 USE oce, ONLY : ssh ! sea-surface height for qco substitution 18 18 19 19 USE in_out_manager -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ISF/isfrst.F90
r14037 r14062 28 28 !!---------------------------------------------------------------------- 29 29 CONTAINS 30 !31 SUBROUTINE isfrst_read( cdisf, ptsc, pfwf, ptsc_b, pfwf_b )30 31 SUBROUTINE isfrst_read( cdisf, ptsc, pfwf, ptsc_b, pfwf_b ) 32 32 !!--------------------------------------------------------------------- 33 33 !! … … 51 51 ! 52 52 ! read restart 53 IF( iom_varid( numror, cfwf_b, ldstop = .FALSE. ) > 0) THEN53 IF( .NOT.l_1st_euler ) THEN 54 54 IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file' 55 55 CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) ) ! before ice shelf melt … … 62 62 ! 63 63 END SUBROUTINE isfrst_read 64 ! 65 SUBROUTINE isfrst_write(kt, cdisf, ptsc, pfwf ) 64 65 66 SUBROUTINE isfrst_write( kt, cdisf, ptsc, pfwf ) 66 67 !!--------------------------------------------------------------------- 67 68 !! … … 94 95 ! 95 96 END SUBROUTINE isfrst_write 96 ! 97 98 !!====================================================================== 97 99 END MODULE isfrst -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/LBC/mppini.F90
r14037 r14062 217 217 ! then we calculate them here now that we have our communicator size 218 218 IF(lwp) THEN 219 WRITE(numout,*) 219 220 WRITE(numout,*) 'mpp_init:' 220 221 WRITE(numout,*) '~~~~~~~~ ' 221 WRITE(numout,*)222 222 ENDIF 223 223 IF( jpni < 1 .OR. jpnj < 1 ) THEN -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/LDF/ldfdyn.F90
r14037 r14062 34 34 ! !!* Namelist namdyn_ldf : lateral mixing on momentum * 35 35 LOGICAL , PUBLIC :: ln_dynldf_OFF !: No operator (i.e. no explicit diffusion) 36 INTEGER , PUBLIC :: nn_dynldf_typ !: operator type (0: div-rot ; 1: symmetric) 36 37 LOGICAL , PUBLIC :: ln_dynldf_lap !: laplacian operator 37 38 LOGICAL , PUBLIC :: ln_dynldf_blp !: bilaplacian operator … … 52 53 53 54 ! !!* Parameter to control the type of lateral viscous operator 54 INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 !: error in setting the operator 55 INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 !: without operator (i.e. no lateral viscous trend) 55 INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 !: error in setting the operator 56 INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 !: without operator (i.e. no lateral viscous trend) 57 ! 58 INTEGER, PARAMETER, PUBLIC :: np_typ_rot = 0 !: div-rot operator 59 INTEGER, PARAMETER, PUBLIC :: np_typ_sym = 1 !: symmetric operator 60 ! 56 61 ! !! laplacian ! bilaplacian ! 57 62 INTEGER, PARAMETER, PUBLIC :: np_lap = 10 , np_blp = 20 !: iso-level operator … … 109 114 CHARACTER(len=5) :: cl_Units ! units (m2/s or m4/s) 110 115 !! 111 NAMELIST/namdyn_ldf/ ln_dynldf_OFF, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator112 & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso, & ! acting direction of the operator113 & nn_ahm_ijk_t , rn_Uv , rn_Lv, rn_ahm_b,& ! lateral eddy coefficient114 & rn_csmc , rn_minfac , rn_maxfac ! Smagorinsky settings116 NAMELIST/namdyn_ldf/ ln_dynldf_OFF, nn_dynldf_typ, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator 117 & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso, & ! acting direction of the operator 118 & nn_ahm_ijk_t , rn_Uv , rn_Lv , rn_ahm_b, & ! lateral eddy coefficient 119 & rn_csmc , rn_minfac , rn_maxfac ! Smagorinsky settings 115 120 !!---------------------------------------------------------------------- 116 121 ! … … 130 135 WRITE(numout,*) ' type :' 131 136 WRITE(numout,*) ' no explicit diffusion ln_dynldf_OFF = ', ln_dynldf_OFF 137 WRITE(numout,*) ' type of operator (div-rot or sym) nn_dynldf_typ = ', nn_dynldf_typ 132 138 WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap 133 139 WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp … … 147 153 WRITE(numout,*) ' Smagorinsky coefficient rn_csmc = ', rn_csmc 148 154 WRITE(numout,*) ' factor multiplier for eddy visc.' 149 WRITE(numout,*) ' lower limit (default 1.0) rn_minfac = ', rn_minfac150 WRITE(numout,*) ' upper limit (default 1.0) rn_maxfac = ', rn_maxfac155 WRITE(numout,*) ' lower limit (default 1.0) rn_minfac = ', rn_minfac 156 WRITE(numout,*) ' upper limit (default 1.0) rn_maxfac = ', rn_maxfac 151 157 ENDIF 152 158 … … 160 166 IF( ln_dynldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF 161 167 IF( ln_dynldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF 162 IF( ioptio /= 1 ) CALL ctl_stop( ' dyn_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' )168 IF( ioptio /= 1 ) CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 operator options (NONE/lap/blp)' ) 163 169 ! 164 170 IF(.NOT.ln_dynldf_OFF ) THEN !== direction ==>> type of operator ==! 171 ! 172 SELECT CASE( nn_dynldf_typ ) ! div-rot or symmetric 173 CASE( np_typ_rot ) ; IF(lwp) WRITE(numout,*) ' ==>>> use div-rot operator ' 174 CASE( np_typ_sym ) ; IF(lwp) WRITE(numout,*) ' ==>>> use symmetric operator ' 175 CASE DEFAULT ! error 176 CALL ctl_stop('ldf_dyn_init: wrong value for nn_dynldf_typ (0 or 1)' ) 177 END SELECT 178 ! 165 179 ioptio = 0 166 180 IF( ln_dynldf_lev ) ioptio = ioptio + 1 167 181 IF( ln_dynldf_hor ) ioptio = ioptio + 1 168 182 IF( ln_dynldf_iso ) ioptio = ioptio + 1 169 IF( ioptio /= 1 ) CALL ctl_stop( ' dyn_ldf_init: use ONE of the 3 direction options (level/hor/iso)' )183 IF( ioptio /= 1 ) CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 direction options (level/hor/iso)' ) 170 184 ! 171 185 ! ! Set nldf_dyn, the type of lateral diffusion, from ln_dynldf_... logicals -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/diaobs.F90
r13216 r14062 57 57 PUBLIC calc_date ! Compute the date of a timestep 58 58 59 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 60 LOGICAL :: ln_sstnight ! Logical switch for night mean SST obs 61 LOGICAL :: ln_sla_fp_indegs ! T=> SLA obs footprint size specified in degrees, F=> in metres 62 LOGICAL :: ln_sst_fp_indegs ! T=> SST obs footprint size specified in degrees, F=> in metres 63 LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres 64 LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres 65 66 REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) 67 REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) 68 REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) 69 REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) 70 REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) 71 REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) 72 REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) 73 REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) 74 75 INTEGER :: nn_1dint ! Vertical interpolation method 76 INTEGER :: nn_2dint ! Default horizontal interpolation method 77 INTEGER :: nn_2dint_sla ! SLA horizontal interpolation method 78 INTEGER :: nn_2dint_sst ! SST horizontal interpolation method 79 INTEGER :: nn_2dint_sss ! SSS horizontal interpolation method 80 INTEGER :: nn_2dint_sic ! Seaice horizontal interpolation method 59 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 60 LOGICAL :: ln_sstnight ! Logical switch for night mean SST obs 61 LOGICAL :: ln_default_fp_indegs ! T=> Default obs footprint size specified in degrees, F=> in metres 62 LOGICAL :: ln_sla_fp_indegs ! T=> SLA obs footprint size specified in degrees, F=> in metres 63 LOGICAL :: ln_sst_fp_indegs ! T=> SST obs footprint size specified in degrees, F=> in metres 64 LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres 65 LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres 66 67 REAL(wp) :: rn_default_avglamscl ! E/W diameter of SLA observation footprint (metres) 68 REAL(wp) :: rn_default_avgphiscl ! N/S diameter of SLA observation footprint (metre 69 REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) 70 REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) 71 REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) 72 REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) 73 REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) 74 REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) 75 REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) 76 REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) 77 78 INTEGER :: nn_1dint ! Vertical interpolation method 79 INTEGER :: nn_2dint_default ! Default horizontal interpolation method 80 INTEGER :: nn_2dint_sla ! SLA horizontal interpolation method 81 INTEGER :: nn_2dint_sst ! SST horizontal interpolation method 82 INTEGER :: nn_2dint_sss ! SSS horizontal interpolation method 83 INTEGER :: nn_2dint_sic ! Seaice horizontal interpolation method 81 84 INTEGER, DIMENSION(imaxavtypes) :: nn_profdavtypes ! Profile data types representing a daily average 82 85 INTEGER :: nproftypes ! Number of profile obs types … … 94 97 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc !: Profile data after quality control 95 98 96 CHARACTER(len= lca), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types99 CHARACTER(len=8), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types 97 100 98 101 !!---------------------------------------------------------------------- … … 121 124 INTEGER :: jvar ! Counter for variables 122 125 INTEGER :: jfile ! Counter for files 123 INTEGER :: jnumsstbias 126 INTEGER :: jnumsstbias ! Number of SST bias files to read and apply 127 INTEGER :: n2dint_type ! Local version of nn_2dint* 124 128 ! 125 129 CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & … … 130 134 & cn_sicfbfiles, & ! Seaice concentration input filenames 131 135 & cn_velfbfiles, & ! Velocity profile input filenames 132 & cn_sstbiasfiles ! SST bias input filenames136 & cn_sstbiasfiles ! SST bias input filenames 133 137 CHARACTER(LEN=128) :: & 134 138 & cn_altbiasfile ! Altimeter bias input filename … … 136 140 & clproffiles, & ! Profile filenames 137 141 & clsurffiles ! Surface filenames 142 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: & 143 & clvars ! Expected variable names 138 144 ! 139 145 LOGICAL :: ln_t3d ! Logical switch for temperature profiles … … 150 156 LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs 151 157 LOGICAL :: ln_bound_reject ! Logical to remove obs near boundaries in LAMs. 152 LOGICAL :: llvar1 ! Logical for profile variable 1 153 LOGICAL :: llvar2 ! Logical for profile variable 1 158 LOGICAL :: ltype_fp_indegs ! Local version of ln_*_fp_indegs 159 LOGICAL :: ltype_night ! Local version of ln_sstnight (false for other variables) 160 LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar ! Logical for profile variable read 154 161 LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files 155 162 ! 156 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 157 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 158 REAL(wp), DIMENSION(jpi,jpj) :: zglam1, zglam2 ! Model longitudes for profile variable 1 & 2 159 REAL(wp), DIMENSION(jpi,jpj) :: zgphi1, zgphi2 ! Model latitudes for profile variable 1 & 2 160 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2 ! Model land/sea mask associated with variable 1 & 2 163 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 164 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 165 REAL(wp) :: ztype_avglamscl ! Local version of rn_*_avglamscl 166 REAL(wp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl 167 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zglam ! Model longitudes for profile variables 168 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zgphi ! Model latitudes for profile variables 169 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zmask ! Model land/sea mask associated with variables 161 170 !! 162 171 NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & … … 165 174 & ln_grid_global, ln_grid_search_lookup, & 166 175 & ln_ignmis, ln_s_at_t, ln_bound_reject, & 167 & ln_sstnight, 176 & ln_sstnight, ln_default_fp_indegs, & 168 177 & ln_sla_fp_indegs, ln_sst_fp_indegs, & 169 178 & ln_sss_fp_indegs, ln_sic_fp_indegs, & … … 174 183 & cn_gridsearchfile, rn_gridsearchres, & 175 184 & rn_dobsini, rn_dobsend, & 185 & rn_default_avglamscl, rn_default_avgphiscl, & 176 186 & rn_sla_avglamscl, rn_sla_avgphiscl, & 177 187 & rn_sst_avglamscl, rn_sst_avgphiscl, & 178 188 & rn_sss_avglamscl, rn_sss_avgphiscl, & 179 189 & rn_sic_avglamscl, rn_sic_avgphiscl, & 180 & nn_1dint, nn_2dint ,&190 & nn_1dint, nn_2dint_default, & 181 191 & nn_2dint_sla, nn_2dint_sst, & 182 192 & nn_2dint_sss, nn_2dint_sic, & … … 234 244 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend 235 245 WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint 236 WRITE(numout,*) ' Type of horizontal interpolation method nn_2dint = ', nn_2dint 246 WRITE(numout,*) ' Default horizontal interpolation method nn_2dint_default = ', nn_2dint_default 247 WRITE(numout,*) ' Type of horizontal interpolation method for SLA nn_2dint_sla = ', nn_2dint_sla 248 WRITE(numout,*) ' Type of horizontal interpolation method for SST nn_2dint_sst = ', nn_2dint_sst 249 WRITE(numout,*) ' Type of horizontal interpolation method for SSS nn_2dint_sss = ', nn_2dint_sss 250 WRITE(numout,*) ' Type of horizontal interpolation method for SIC nn_2dint_sic = ', nn_2dint_sic 251 WRITE(numout,*) ' Default E/W diameter of obs footprint rn_default_avglamscl = ', rn_default_avglamscl 252 WRITE(numout,*) ' Default N/S diameter of obs footprint rn_default_avgphiscl = ', rn_default_avgphiscl 253 WRITE(numout,*) ' Default obs footprint in deg [T] or m [F] ln_default_fp_indegs = ', ln_default_fp_indegs 254 WRITE(numout,*) ' SLA E/W diameter of obs footprint rn_sla_avglamscl = ', rn_sla_avglamscl 255 WRITE(numout,*) ' SLA N/S diameter of obs footprint rn_sla_avgphiscl = ', rn_sla_avgphiscl 256 WRITE(numout,*) ' SLA obs footprint in deg [T] or m [F] ln_sla_fp_indegs = ', ln_sla_fp_indegs 257 WRITE(numout,*) ' SST E/W diameter of obs footprint rn_sst_avglamscl = ', rn_sst_avglamscl 258 WRITE(numout,*) ' SST N/S diameter of obs footprint rn_sst_avgphiscl = ', rn_sst_avgphiscl 259 WRITE(numout,*) ' SST obs footprint in deg [T] or m [F] ln_sst_fp_indegs = ', ln_sst_fp_indegs 260 WRITE(numout,*) ' SIC E/W diameter of obs footprint rn_sic_avglamscl = ', rn_sic_avglamscl 261 WRITE(numout,*) ' SIC N/S diameter of obs footprint rn_sic_avgphiscl = ', rn_sic_avgphiscl 262 WRITE(numout,*) ' SIC obs footprint in deg [T] or m [F] ln_sic_fp_indegs = ', ln_sic_fp_indegs 237 263 WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea 238 264 WRITE(numout,*) ' Rejection of obs near open bdys ln_bound_reject = ', ln_bound_reject … … 278 304 IF( ln_t3d .OR. ln_s3d ) THEN 279 305 jtype = jtype + 1 280 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof ', &281 & cn_profbfiles, ifilesprof, cobstypesprof, clproffiles )306 cobstypesprof(jtype) = 'prof' 307 clproffiles(jtype,:) = cn_profbfiles 282 308 ENDIF 283 309 IF( ln_vel3d ) THEN 284 310 jtype = jtype + 1 285 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel ', &286 & cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles )311 cobstypesprof(jtype) = 'vel' 312 clproffiles(jtype,:) = cn_velfbfiles 287 313 ENDIF 314 ! 315 CALL obs_settypefiles( nproftypes, jpmaxnfiles, ifilesprof, cobstypesprof, clproffiles ) 288 316 ! 289 317 ENDIF … … 303 331 IF( ln_sla ) THEN 304 332 jtype = jtype + 1 305 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla ', & 306 & cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles ) 307 CALL obs_setinterpopts( nsurftypes, jtype, 'sla ', & 308 & nn_2dint, nn_2dint_sla, & 309 & rn_sla_avglamscl, rn_sla_avgphiscl, & 310 & ln_sla_fp_indegs, .FALSE., & 311 & n2dintsurf, zavglamscl, zavgphiscl, & 312 & lfpindegs, llnightav ) 333 cobstypessurf(jtype) = 'sla' 334 clsurffiles(jtype,:) = cn_slafbfiles 313 335 ENDIF 314 336 IF( ln_sst ) THEN 315 337 jtype = jtype + 1 316 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst ', & 317 & cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 318 CALL obs_setinterpopts( nsurftypes, jtype, 'sst ', & 319 & nn_2dint, nn_2dint_sst, & 320 & rn_sst_avglamscl, rn_sst_avgphiscl, & 321 & ln_sst_fp_indegs, ln_sstnight, & 322 & n2dintsurf, zavglamscl, zavgphiscl, & 323 & lfpindegs, llnightav ) 338 cobstypessurf(jtype) = 'sst' 339 clsurffiles(jtype,:) = cn_sstfbfiles 324 340 ENDIF 325 341 #if defined key_si3 || defined key_cice 326 342 IF( ln_sic ) THEN 327 343 jtype = jtype + 1 328 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic ', & 329 & cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 330 CALL obs_setinterpopts( nsurftypes, jtype, 'sic ', & 331 & nn_2dint, nn_2dint_sic, & 332 & rn_sic_avglamscl, rn_sic_avgphiscl, & 333 & ln_sic_fp_indegs, .FALSE., & 334 & n2dintsurf, zavglamscl, zavgphiscl, & 335 & lfpindegs, llnightav ) 344 cobstypessurf(jtype) = 'sic' 345 clsurffiles(jtype,:) = cn_sicfbfiles 336 346 ENDIF 337 347 #endif 338 348 IF( ln_sss ) THEN 339 349 jtype = jtype + 1 340 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss ', & 341 & cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 342 CALL obs_setinterpopts( nsurftypes, jtype, 'sss ', & 343 & nn_2dint, nn_2dint_sss, & 344 & rn_sss_avglamscl, rn_sss_avgphiscl, & 345 & ln_sss_fp_indegs, .FALSE., & 346 & n2dintsurf, zavglamscl, zavgphiscl, & 347 & lfpindegs, llnightav ) 350 cobstypessurf(jtype) = 'sss' 351 clsurffiles(jtype,:) = cn_sssfbfiles 348 352 ENDIF 353 ! 354 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, ifilessurf, cobstypessurf, clsurffiles ) 355 356 DO jtype = 1, nsurftypes 357 358 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 359 IF ( nn_2dint_sla == -1 ) THEN 360 n2dint_type = nn_2dint_default 361 ELSE 362 n2dint_type = nn_2dint_sla 363 ENDIF 364 ztype_avglamscl = rn_sla_avglamscl 365 ztype_avgphiscl = rn_sla_avgphiscl 366 ltype_fp_indegs = ln_sla_fp_indegs 367 ltype_night = .FALSE. 368 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 369 IF ( nn_2dint_sst == -1 ) THEN 370 n2dint_type = nn_2dint_default 371 ELSE 372 n2dint_type = nn_2dint_sst 373 ENDIF 374 ztype_avglamscl = rn_sst_avglamscl 375 ztype_avgphiscl = rn_sst_avgphiscl 376 ltype_fp_indegs = ln_sst_fp_indegs 377 ltype_night = ln_sstnight 378 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 379 IF ( nn_2dint_sic == -1 ) THEN 380 n2dint_type = nn_2dint_default 381 ELSE 382 n2dint_type = nn_2dint_sic 383 ENDIF 384 ztype_avglamscl = rn_sic_avglamscl 385 ztype_avgphiscl = rn_sic_avgphiscl 386 ltype_fp_indegs = ln_sic_fp_indegs 387 ltype_night = .FALSE. 388 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 389 IF ( nn_2dint_sss == -1 ) THEN 390 n2dint_type = nn_2dint_default 391 ELSE 392 n2dint_type = nn_2dint_sss 393 ENDIF 394 ztype_avglamscl = rn_sss_avglamscl 395 ztype_avgphiscl = rn_sss_avgphiscl 396 ltype_fp_indegs = ln_sss_fp_indegs 397 ltype_night = .FALSE. 398 ELSE 399 n2dint_type = nn_2dint_default 400 ztype_avglamscl = rn_default_avglamscl 401 ztype_avgphiscl = rn_default_avgphiscl 402 ltype_fp_indegs = ln_default_fp_indegs 403 ltype_night = .FALSE. 404 ENDIF 405 406 CALL obs_setinterpopts( nsurftypes, jtype, TRIM(cobstypessurf(jtype)), & 407 & nn_2dint_default, n2dint_type, & 408 & ztype_avglamscl, ztype_avgphiscl, & 409 & ltype_fp_indegs, ltype_night, & 410 & n2dintsurf, zavglamscl, zavgphiscl, & 411 & lfpindegs, llnightav ) 412 413 END DO 349 414 ! 350 415 ENDIF … … 368 433 ENDIF 369 434 ! 370 IF( nn_2dint < 0 .OR. nn_2dint > 6 ) THEN371 CALL ctl_stop('dia_obs_init: Choice of horizontal (2D) interpolation method is not available')435 IF( nn_2dint_default < 0 .OR. nn_2dint_default > 6 ) THEN 436 CALL ctl_stop('dia_obs_init: Choice of default horizontal (2D) interpolation method is not available') 372 437 ENDIF 373 438 ! … … 388 453 DO jtype = 1, nproftypes 389 454 ! 390 nvarsprof(jtype) = 2391 455 IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 392 nextrprof(jtype) = 1 393 llvar1 = ln_t3d 394 llvar2 = ln_s3d 395 zglam1 = glamt 396 zgphi1 = gphit 397 zmask1 = tmask 398 zglam2 = glamt 399 zgphi2 = gphit 400 zmask2 = tmask 401 ENDIF 402 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 456 nvarsprof(jtype) = 2 457 nextrprof(jtype) = 1 458 ALLOCATE( llvar (nvarsprof(jtype)) ) 459 ALLOCATE( clvars(nvarsprof(jtype)) ) 460 ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) 461 ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) 462 ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 463 llvar(1) = ln_t3d 464 llvar(2) = ln_s3d 465 clvars(1) = 'POTM' 466 clvars(2) = 'PSAL' 467 zglam(:,:,1) = glamt(:,:) 468 zglam(:,:,2) = glamt(:,:) 469 zgphi(:,:,1) = gphit(:,:) 470 zgphi(:,:,2) = gphit(:,:) 471 zmask(:,:,:,1) = tmask(:,:,:) 472 zmask(:,:,:,2) = tmask(:,:,:) 473 ELSE IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 474 nvarsprof(jtype) = 2 403 475 nextrprof(jtype) = 2 404 llvar1 = ln_vel3d 405 llvar2 = ln_vel3d 406 zglam1 = glamu 407 zgphi1 = gphiu 408 zmask1 = umask 409 zglam2 = glamv 410 zgphi2 = gphiv 411 zmask2 = vmask 476 ALLOCATE( llvar (nvarsprof(jtype)) ) 477 ALLOCATE( clvars(nvarsprof(jtype)) ) 478 ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) 479 ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) 480 ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 481 llvar(1) = ln_vel3d 482 llvar(2) = ln_vel3d 483 clvars(1) = 'UVEL' 484 clvars(2) = 'VVEL' 485 zglam(:,:,1) = glamu(:,:) 486 zglam(:,:,2) = glamv(:,:) 487 zgphi(:,:,1) = gphiu(:,:) 488 zgphi(:,:,2) = gphiv(:,:) 489 zmask(:,:,:,1) = umask(:,:,:) 490 zmask(:,:,:,2) = vmask(:,:,:) 491 ELSE 492 nvarsprof(jtype) = 1 493 nextrprof(jtype) = 0 494 ALLOCATE( llvar (nvarsprof(jtype)) ) 495 ALLOCATE( clvars(nvarsprof(jtype)) ) 496 ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) 497 ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) 498 ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 499 llvar(1) = .TRUE. 500 zglam(:,:,1) = glamt(:,:) 501 zgphi(:,:,1) = gphit(:,:) 502 zmask(:,:,:,1) = tmask(:,:,:) 412 503 ENDIF 413 504 ! … … 416 507 & clproffiles(jtype,1:ifilesprof(jtype)), & 417 508 & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 418 & rn_dobsini, rn_dobsend, llvar 1, llvar2, &419 & ln_ignmis, ln_s_at_t, .FALSE., &509 & rn_dobsini, rn_dobsend, llvar, & 510 & ln_ignmis, ln_s_at_t, .FALSE., clvars, & 420 511 & kdailyavtypes = nn_profdavtypes ) 421 512 ! … … 425 516 ! 426 517 CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 427 & llvar 1, llvar2, &518 & llvar, & 428 519 & jpi, jpj, jpk, & 429 & zmask 1, zglam1, zgphi1, zmask2, zglam2, zgphi2,&520 & zmask, zglam, zgphi, & 430 521 & ln_nea, ln_bound_reject, Kmm, & 431 522 & kdailyavtypes = nn_profdavtypes ) 523 ! 524 DEALLOCATE( llvar, clvars, zglam, zgphi, zmask ) 525 ! 432 526 END DO 433 527 ! … … 449 543 IF( TRIM(cobstypessurf(jtype)) == 'sst' ) llnightav(jtype) = ln_sstnight 450 544 ! 545 ALLOCATE( clvars( nvarssurf(jtype) ) ) 546 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 547 clvars(1) = 'SLA' 548 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 549 clvars(1) = 'SST' 550 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 551 clvars(1) = 'ICECONC' 552 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 553 clvars(1) = 'SSS' 554 ENDIF 555 ! 451 556 ! Read in surface obs types 452 557 CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 453 558 & clsurffiles(jtype,1:ifilessurf(jtype)), & 454 559 & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 455 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) ) 560 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype), & 561 & clvars ) 456 562 ! 457 563 CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) … … 473 579 & jnumsstbias , cn_sstbiasfiles(1:jnumsstbias) ) 474 580 ENDIF 581 ! 582 DEALLOCATE( clvars ) 475 583 END DO 476 584 ! … … 516 624 INTEGER :: jvar ! Variable number 517 625 INTEGER :: ji, jj ! Loop counters 518 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 519 & zprofvar1, & ! Model values for 1st variable in a prof ob 520 & zprofvar2 ! Model values for 2nd variable in a prof ob 521 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 522 & zprofmask1, & ! Mask associated with zprofvar1 523 & zprofmask2 ! Mask associated with zprofvar2 626 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 627 & zprofvar ! Model values for variables in a prof ob 628 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 629 & zprofmask ! Mask associated with zprofvar 524 630 REAL(wp), DIMENSION(jpi,jpj) :: & 525 631 & zsurfvar, & ! Model values equivalent to surface ob. 526 632 & zsurfmask ! Mask associated with surface variable 527 REAL(wp), DIMENSION(jpi,jpj) :: & 528 & zglam1, & ! Model longitudes for prof variable 1 529 & zglam2, & ! Model longitudes for prof variable 2 530 & zgphi1, & ! Model latitudes for prof variable 1 531 & zgphi2 ! Model latitudes for prof variable 2 633 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 634 & zglam, & ! Model longitudes for prof variables 635 & zgphi ! Model latitudes for prof variables 532 636 533 637 !----------------------------------------------------------------------- … … 549 653 DO jtype = 1, nproftypes 550 654 655 ! Allocate local work arrays 656 ALLOCATE( zprofvar (jpi, jpj, jpk, profdataqc(jtype)%nvar) ) 657 ALLOCATE( zprofmask(jpi, jpj, jpk, profdataqc(jtype)%nvar) ) 658 ALLOCATE( zglam (jpi, jpj, profdataqc(jtype)%nvar) ) 659 ALLOCATE( zgphi (jpi, jpj, profdataqc(jtype)%nvar) ) 660 661 ! Defaults which might change 662 DO jvar = 1, profdataqc(jtype)%nvar 663 zprofmask(:,:,:,jvar) = tmask(:,:,:) 664 zglam(:,:,jvar) = glamt(:,:) 665 zgphi(:,:,jvar) = gphit(:,:) 666 END DO 667 551 668 SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 552 669 CASE('prof') 553 zprofvar1(:,:,:) = ts(:,:,:,jp_tem,Kmm) 554 zprofvar2(:,:,:) = ts(:,:,:,jp_sal,Kmm) 555 zprofmask1(:,:,:) = tmask(:,:,:) 556 zprofmask2(:,:,:) = tmask(:,:,:) 557 zglam1(:,:) = glamt(:,:) 558 zglam2(:,:) = glamt(:,:) 559 zgphi1(:,:) = gphit(:,:) 560 zgphi2(:,:) = gphit(:,:) 670 zprofvar(:,:,:,1) = ts(:,:,:,jp_tem,Kmm) 671 zprofvar(:,:,:,2) = ts(:,:,:,jp_sal,Kmm) 561 672 CASE('vel') 562 zprofvar 1(:,:,:) = uu(:,:,:,Kmm)563 zprofvar 2(:,:,:) = vv(:,:,:,Kmm)564 zprofmask 1(:,:,:) = umask(:,:,:)565 zprofmask 2(:,:,:) = vmask(:,:,:)566 zglam 1(:,:) = glamu(:,:)567 zglam 2(:,:) = glamv(:,:)568 zgphi 1(:,:) = gphiu(:,:)569 zgphi 2(:,:) = gphiv(:,:)673 zprofvar(:,:,:,1) = uu(:,:,:,Kmm) 674 zprofvar(:,:,:,2) = vv(:,:,:,Kmm) 675 zprofmask(:,:,:,1) = umask(:,:,:) 676 zprofmask(:,:,:,2) = vmask(:,:,:) 677 zglam(:,:,1) = glamu(:,:) 678 zglam(:,:,2) = glamv(:,:) 679 zgphi(:,:,1) = gphiu(:,:) 680 zgphi(:,:,2) = gphiv(:,:) 570 681 CASE DEFAULT 571 682 CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) 572 683 END SELECT 573 684 574 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 575 & nit000, idaystp, & 576 & zprofvar1, zprofvar2, & 577 & gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm), & 578 & zprofmask1, zprofmask2, & 579 & zglam1, zglam2, zgphi1, zgphi2, & 580 & nn_1dint, nn_2dint, & 581 & kdailyavtypes = nn_profdavtypes ) 685 DO jvar = 1, profdataqc(jtype)%nvar 686 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 687 & nit000, idaystp, jvar, & 688 & zprofvar(:,:,:,jvar), & 689 & gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm), & 690 & zprofmask(:,:,:,jvar), & 691 & zglam(:,:,jvar), zgphi(:,:,jvar), & 692 & nn_1dint, nn_2dint_default, & 693 & kdailyavtypes = nn_profdavtypes ) 694 END DO 695 696 DEALLOCATE( zprofvar, zprofmask, zglam, zgphi ) 582 697 583 698 END DO … … 680 795 & ) 681 796 682 CALL obs_rotvel( profdataqc(jtype), nn_2dint , zu, zv )797 CALL obs_rotvel( profdataqc(jtype), nn_2dint_default, zu, zv ) 683 798 684 799 DO jo = 1, profdataqc(jtype)%nprof … … 896 1011 END SUBROUTINE fin_date 897 1012 898 SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, &899 & cfilestype, ifiles, cobstypes, cfiles ) 900 901 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types902 INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type903 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs904 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &905 & ifiles ! Out appended number of files for this type906 907 CHARACTER(len=6), INTENT(IN) :: ctypein908 CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: & 909 & cfilestype ! In list of files for this obs type910 CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: &911 & cobstypes ! Out appended list of obs types912 CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: & 913 & cfiles ! Out appended list of files for alltypes914 915 !Local variables916 INTEGER :: jfile917 918 cfiles(jtype,:) = cfilestype(:)919 cobstypes(jtype) = ctypein920 ifiles(jtype) = 0 921 DO jfile = 1, jpmaxnfiles922 IF ( trim(cfiles(jtype,jfile)) /= '' )&923 ifiles(jtype) = ifiles(jtype) + 1924 END DO925 926 IF ( ifiles(jtype) == 0 ) THEN927 CALL ctl_stop( 'Logical for observation type '//TRIM(ctypein)// &928 & ' set to true but no files available to read')929 ENDIF930 931 IF(lwp) THEN932 WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' 933 DO jfile = 1, ifiles(jtype)934 WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) 935 END DO936 ENDIF 937 938 END SUBROUTINE obs_settypefiles939 940 SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein,&941 & n2dint_default, n2dint_type,&942 & zavglamscl_type, zavgphiscl_type, &943 & lfp_indegs_type, lavnight_type, & 944 & n2dint, zavglamscl, zavgphiscl, &945 & lfpindegs, lavnight )946 947 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types948 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs949 INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolationtype950 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolationtype951 REAL(wp), INTENT(IN) :: &952 & zavglamscl_type, & !E/W diameter of obs footprint for this type953 & zavgphiscl_type !N/S diameter of obs footprint for this type954 LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres 955 LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average956 CHARACTER(len=6), INTENT(IN) :: ctypein957 958 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &959 & n2dint960 REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: &961 & zavglamscl, zavgphiscl 962 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: &963 & lfpindegs, lavnight 964 965 lavnight(jtype) = lavnight_type966 967 IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN968 n2dint(jtype) = n2dint_type969 ELSE970 n2dint(jtype) = n2dint_default971 ENDIF972 973 ! For averaging observation footprints set options for size of footprint974 IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN975 IF ( zavglamscl_type > 0._wp ) THEN976 zavglamscl(jtype) = zavglamscl_type977 ELSE978 CALL ctl_stop( 'Incorrect value set for averaging footprint '// &979 'scale (zavglamscl) for observation type '//TRIM(ctypein) )980 ENDIF981 982 IF ( zavgphiscl_type > 0._wp ) THEN983 zavgphiscl(jtype) = zavgphiscl_type984 ELSE985 CALL ctl_stop( 'Incorrect value set for averaging footprint '// &986 'scale (zavgphiscl) for observation type '//TRIM(ctypein) )987 ENDIF988 989 lfpindegs(jtype) = lfp_indegs_type990 991 ENDIF992 993 ! Write out info994 IF(lwp) THEN995 IF ( n2dint(jtype) <= 4 ) THEN996 WRITE(numout,*) ' '//TRIM(ctypein)// &997 & ' model counterparts will be interpolated horizontally'998 ELSE IF ( n2dint(jtype) <= 6 ) THEN999 WRITE(numout,*) ' '//TRIM(ctypein)// &1000 & ' model counterparts will be averaged horizontally'1001 WRITE(numout,*) ' '//' with E/W scale: ',zavglamscl(jtype)1002 WRITE(numout,*) ' '//' with N/S scale: ',zavgphiscl(jtype)1003 IF ( lfpindegs(jtype) ) THEN1004 WRITE(numout,*) ' '//' (in degrees)'1005 ELSE1006 WRITE(numout,*) ' '//' (in metres)'1007 ENDIF1008 ENDIF1009 ENDIF1010 1011 1013 SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, ifiles, cobstypes, cfiles ) 1014 1015 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1016 INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type 1017 INTEGER, DIMENSION(ntypes), INTENT(OUT) :: & 1018 & ifiles ! Out number of files for each type 1019 CHARACTER(len=8), DIMENSION(ntypes), INTENT(IN) :: & 1020 & cobstypes ! List of obs types 1021 CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(IN) :: & 1022 & cfiles ! List of files for all types 1023 1024 !Local variables 1025 INTEGER :: jfile 1026 INTEGER :: jtype 1027 1028 DO jtype = 1, ntypes 1029 1030 ifiles(jtype) = 0 1031 DO jfile = 1, jpmaxnfiles 1032 IF ( trim(cfiles(jtype,jfile)) /= '' ) & 1033 ifiles(jtype) = ifiles(jtype) + 1 1034 END DO 1035 1036 IF ( ifiles(jtype) == 0 ) THEN 1037 CALL ctl_stop( 'Logical for observation type '//TRIM(cobstypes(jtype))// & 1038 & ' set to true but no files available to read' ) 1039 ENDIF 1040 1041 IF(lwp) THEN 1042 WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' 1043 DO jfile = 1, ifiles(jtype) 1044 WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) 1045 END DO 1046 ENDIF 1047 1048 END DO 1049 1050 END SUBROUTINE obs_settypefiles 1051 1052 SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein, & 1053 & n2dint_default, n2dint_type, & 1054 & ravglamscl_type, ravgphiscl_type, & 1055 & lfp_indegs_type, lavnight_type, & 1056 & n2dint, ravglamscl, ravgphiscl, & 1057 & lfpindegs, lavnight ) 1058 1059 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1060 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs 1061 INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolation type 1062 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type 1063 REAL(wp), INTENT(IN) :: & 1064 & ravglamscl_type, & !E/W diameter of obs footprint for this type 1065 & ravgphiscl_type !N/S diameter of obs footprint for this type 1066 LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres 1067 LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average 1068 CHARACTER(len=8), INTENT(IN) :: ctypein 1069 1070 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 1071 & n2dint 1072 REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & 1073 & ravglamscl, ravgphiscl 1074 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & 1075 & lfpindegs, lavnight 1076 1077 lavnight(jtype) = lavnight_type 1078 1079 IF ( (n2dint_type >= 0) .AND. (n2dint_type <= 6) ) THEN 1080 n2dint(jtype) = n2dint_type 1081 ELSE IF ( n2dint_type == -1 ) THEN 1082 n2dint(jtype) = n2dint_default 1083 ELSE 1084 CALL ctl_stop(' Choice of '//TRIM(ctypein)//' horizontal (2D) interpolation method', & 1085 & ' is not available') 1086 ENDIF 1087 1088 ! For averaging observation footprints set options for size of footprint 1089 IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN 1090 IF ( ravglamscl_type > 0._wp ) THEN 1091 ravglamscl(jtype) = ravglamscl_type 1092 ELSE 1093 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1094 'scale (ravglamscl) for observation type '//TRIM(ctypein) ) 1095 ENDIF 1096 1097 IF ( ravgphiscl_type > 0._wp ) THEN 1098 ravgphiscl(jtype) = ravgphiscl_type 1099 ELSE 1100 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1101 'scale (ravgphiscl) for observation type '//TRIM(ctypein) ) 1102 ENDIF 1103 1104 lfpindegs(jtype) = lfp_indegs_type 1105 1106 ENDIF 1107 1108 ! Write out info 1109 IF(lwp) THEN 1110 IF ( n2dint(jtype) <= 4 ) THEN 1111 WRITE(numout,*) ' '//TRIM(ctypein)// & 1112 & ' model counterparts will be interpolated horizontally' 1113 ELSE IF ( n2dint(jtype) <= 6 ) THEN 1114 WRITE(numout,*) ' '//TRIM(ctypein)// & 1115 & ' model counterparts will be averaged horizontally' 1116 WRITE(numout,*) ' '//' with E/W scale: ',ravglamscl(jtype) 1117 WRITE(numout,*) ' '//' with N/S scale: ',ravgphiscl(jtype) 1118 IF ( lfpindegs(jtype) ) THEN 1119 WRITE(numout,*) ' '//' (in degrees)' 1120 ELSE 1121 WRITE(numout,*) ' '//' (in metres)' 1122 ENDIF 1123 ENDIF 1124 ENDIF 1125 1126 END SUBROUTINE obs_setinterpopts 1012 1127 1013 1128 END MODULE diaobs -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_oper.F90
r13295 r14062 40 40 CONTAINS 41 41 42 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, 43 & kit000, kdaystp, 44 & pvar 1, pvar2, pgdept, pgdepw,&45 & pmask 1, pmask2, &46 & plam 1, plam2, pphi1, pphi2,&42 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & 43 & kit000, kdaystp, kvar, & 44 & pvar, pgdept, pgdepw, & 45 & pmask, & 46 & plam, pphi, & 47 47 & k1dint, k2dint, kdailyavtypes ) 48 48 !!----------------------------------------------------------------------- … … 105 105 INTEGER , INTENT(in ) :: k2dint ! Horizontal interpolation type (see header) 106 106 INTEGER , INTENT(in ) :: kdaystp ! Number of time steps per day 107 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar1 , pvar2 ! Model field 1 and 2 108 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask1, pmask2 ! Land-sea mask 1 and 2 109 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam1 , plam2 ! Model longitude 1 and 2 110 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi1 , pphi2 ! Model latitudes 1 and 2 107 INTEGER , INTENT(in ) :: kvar ! Number of variables in prodatqc 108 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar ! Model field 109 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask ! Land-sea mask 110 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam ! Model longitude 111 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi ! Model latitudes 111 112 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pgdept, pgdepw ! depth of T and W levels 112 113 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: kdailyavtypes ! Types for daily averages … … 128 129 & idailyavtypes 129 130 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 130 & igrdi1, & 131 & igrdi2, & 132 & igrdj1, & 133 & igrdj2 131 & igrdi, & 132 & igrdj 134 133 INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic 135 134 … … 138 137 REAL(KIND=wp) :: zdaystp 139 138 REAL(KIND=wp), DIMENSION(kpk) :: & 140 & zobsmask1, & 141 & zobsmask2, & 142 & zobsk, & 139 & zobsk, & 143 140 & zobs2k 144 141 REAL(KIND=wp), DIMENSION(2,2,1) :: & 145 142 & zweig1, & 146 & zweig2, &147 143 & zweig 148 144 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 149 & zmask1, & 150 & zmask2, & 151 & zint1, & 152 & zint2, & 153 & zinm1, & 154 & zinm2, & 145 & zmask, & 146 & zint, & 147 & zinm, & 155 148 & zgdept, & 156 149 & zgdepw 157 150 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 158 & zglam1, & 159 & zglam2, & 160 & zgphi1, & 161 & zgphi2 162 REAL(KIND=wp), DIMENSION(1) :: zmsk_1, zmsk_2 151 & zglam, & 152 & zgphi 153 REAL(KIND=wp), DIMENSION(1) :: zmsk 163 154 REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner 164 155 … … 190 181 IF ( idayend == 1 .OR. kt == 0 ) THEN 191 182 DO_3D( 1, 1, 1, 1, 1, jpk ) 192 prodatqc%vdmean(ji,jj,jk,1) = 0.0 193 prodatqc%vdmean(ji,jj,jk,2) = 0.0 183 prodatqc%vdmean(ji,jj,jk,kvar) = 0.0 194 184 END_3D 195 185 ENDIF … … 197 187 DO_3D( 1, 1, 1, 1, 1, jpk ) 198 188 ! Increment field 1 for computing daily mean 199 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 200 & + pvar1(ji,jj,jk) 201 ! Increment field 2 for computing daily mean 202 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 203 & + pvar2(ji,jj,jk) 189 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 190 & + pvar(ji,jj,jk) 204 191 END_3D 205 192 … … 210 197 CALL FLUSH(numout) 211 198 DO_3D( 1, 1, 1, 1, 1, jpk ) 212 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 213 & * zdaystp 214 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 215 & * zdaystp 199 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 200 & * zdaystp 216 201 END_3D 217 202 ENDIF … … 221 206 ! Get the data for interpolation 222 207 ALLOCATE( & 223 & igrdi1(2,2,ipro), & 224 & igrdi2(2,2,ipro), & 225 & igrdj1(2,2,ipro), & 226 & igrdj2(2,2,ipro), & 227 & zglam1(2,2,ipro), & 228 & zglam2(2,2,ipro), & 229 & zgphi1(2,2,ipro), & 230 & zgphi2(2,2,ipro), & 231 & zmask1(2,2,kpk,ipro), & 232 & zmask2(2,2,kpk,ipro), & 233 & zint1(2,2,kpk,ipro), & 234 & zint2(2,2,kpk,ipro), & 235 & zgdept(2,2,kpk,ipro), & 236 & zgdepw(2,2,kpk,ipro) & 208 & igrdi(2,2,ipro), & 209 & igrdj(2,2,ipro), & 210 & zglam(2,2,ipro), & 211 & zgphi(2,2,ipro), & 212 & zmask(2,2,kpk,ipro), & 213 & zint(2,2,kpk,ipro), & 214 & zgdept(2,2,kpk,ipro), & 215 & zgdepw(2,2,kpk,ipro) & 237 216 & ) 238 217 239 218 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 240 219 iobs = jobs - prodatqc%nprofup 241 igrdi1(1,1,iobs) = prodatqc%mi(jobs,1)-1 242 igrdj1(1,1,iobs) = prodatqc%mj(jobs,1)-1 243 igrdi1(1,2,iobs) = prodatqc%mi(jobs,1)-1 244 igrdj1(1,2,iobs) = prodatqc%mj(jobs,1) 245 igrdi1(2,1,iobs) = prodatqc%mi(jobs,1) 246 igrdj1(2,1,iobs) = prodatqc%mj(jobs,1)-1 247 igrdi1(2,2,iobs) = prodatqc%mi(jobs,1) 248 igrdj1(2,2,iobs) = prodatqc%mj(jobs,1) 249 igrdi2(1,1,iobs) = prodatqc%mi(jobs,2)-1 250 igrdj2(1,1,iobs) = prodatqc%mj(jobs,2)-1 251 igrdi2(1,2,iobs) = prodatqc%mi(jobs,2)-1 252 igrdj2(1,2,iobs) = prodatqc%mj(jobs,2) 253 igrdi2(2,1,iobs) = prodatqc%mi(jobs,2) 254 igrdj2(2,1,iobs) = prodatqc%mj(jobs,2)-1 255 igrdi2(2,2,iobs) = prodatqc%mi(jobs,2) 256 igrdj2(2,2,iobs) = prodatqc%mj(jobs,2) 220 igrdi(1,1,iobs) = prodatqc%mi(jobs,kvar)-1 221 igrdj(1,1,iobs) = prodatqc%mj(jobs,kvar)-1 222 igrdi(1,2,iobs) = prodatqc%mi(jobs,kvar)-1 223 igrdj(1,2,iobs) = prodatqc%mj(jobs,kvar) 224 igrdi(2,1,iobs) = prodatqc%mi(jobs,kvar) 225 igrdj(2,1,iobs) = prodatqc%mj(jobs,kvar)-1 226 igrdi(2,2,iobs) = prodatqc%mi(jobs,kvar) 227 igrdj(2,2,iobs) = prodatqc%mj(jobs,kvar) 257 228 END DO 258 229 … … 261 232 zgdepw(:,:,:,:) = 0.0 262 233 263 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, plam1, zglam1 ) 264 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, pphi1, zgphi1 ) 265 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pmask1, zmask1 ) 266 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pvar1, zint1 ) 267 268 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, plam2, zglam2 ) 269 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, pphi2, zgphi2 ) 270 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pmask2, zmask2 ) 271 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pvar2, zint2 ) 272 273 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdept, zgdept ) 274 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdepw, zgdepw ) 234 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, plam, zglam ) 235 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 236 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pmask, zmask ) 237 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pvar, zint ) 238 239 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept, zgdept ) 240 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw, zgdepw ) 275 241 276 242 ! At the end of the day also get interpolated means 277 243 IF ( ld_dailyav .AND. idayend == 0 ) THEN 278 244 279 ALLOCATE( & 280 & zinm1(2,2,kpk,ipro), & 281 & zinm2(2,2,kpk,ipro) & 282 & ) 283 284 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, & 285 & prodatqc%vdmean(:,:,:,1), zinm1 ) 286 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, & 287 & prodatqc%vdmean(:,:,:,2), zinm2 ) 245 ALLOCATE( zinm(2,2,kpk,ipro) ) 246 247 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & 248 & prodatqc%vdmean(:,:,:,kvar), zinm ) 288 249 289 250 ENDIF … … 320 281 ! Horizontal weights 321 282 ! Masked values are calculated later. 322 IF ( prodatqc%npvend(jobs, 1) > 0 ) THEN283 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 323 284 324 285 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 325 & zglam1(:,:,iobs), zgphi1(:,:,iobs), & 326 & zmask1(:,:,1,iobs), zweig1, zmsk_1 ) 327 328 ENDIF 329 330 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 331 332 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 333 & zglam2(:,:,iobs), zgphi2(:,:,iobs), & 334 & zmask2(:,:,1,iobs), zweig2, zmsk_2) 335 336 ENDIF 337 338 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 286 & zglam(:,:,iobs), zgphi(:,:,iobs), & 287 & zmask(:,:,1,iobs), zweig1, zmsk ) 288 289 ENDIF 290 291 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 339 292 340 293 zobsk(:) = obfillflt … … 346 299 347 300 ! vertically interpolate all 4 corners 348 ista = prodatqc%npvsta(jobs, 1)349 iend = prodatqc%npvend(jobs, 1)301 ista = prodatqc%npvsta(jobs,kvar) 302 iend = prodatqc%npvend(jobs,kvar) 350 303 inum_obs = iend - ista + 1 351 304 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) … … 356 309 IF ( k1dint == 1 ) THEN 357 310 CALL obs_int_z1d_spl( kpk, & 358 & zinm 1(iin,ijn,:,iobs), &311 & zinm(iin,ijn,:,iobs), & 359 312 & zobs2k, zgdept(iin,ijn,:,iobs), & 360 & zmask 1(iin,ijn,:,iobs))313 & zmask(iin,ijn,:,iobs)) 361 314 ENDIF 362 315 363 316 CALL obs_level_search(kpk, & 364 317 & zgdept(iin,ijn,:,iobs), & 365 & inum_obs, prodatqc%var( 1)%vdep(ista:iend), &318 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 366 319 & iv_indic) 367 320 368 321 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 369 & prodatqc%var( 1)%vdep(ista:iend), &370 & zinm 1(iin,ijn,:,iobs), &322 & prodatqc%var(kvar)%vdep(ista:iend), & 323 & zinm(iin,ijn,:,iobs), & 371 324 & zobs2k, interp_corner(iin,ijn,:), & 372 325 & zgdept(iin,ijn,:,iobs), & 373 & zmask 1(iin,ijn,:,iobs))326 & zmask(iin,ijn,:,iobs)) 374 327 375 328 ENDDO … … 383 336 384 337 ! vertically interpolate all 4 corners 385 ista = prodatqc%npvsta(jobs, 1)386 iend = prodatqc%npvend(jobs, 1)338 ista = prodatqc%npvsta(jobs,kvar) 339 iend = prodatqc%npvend(jobs,kvar) 387 340 inum_obs = iend - ista + 1 388 341 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) … … 392 345 IF ( k1dint == 1 ) THEN 393 346 CALL obs_int_z1d_spl( kpk, & 394 & zint 1(iin,ijn,:,iobs),&347 & zint(iin,ijn,:,iobs),& 395 348 & zobs2k, zgdept(iin,ijn,:,iobs), & 396 & zmask 1(iin,ijn,:,iobs))349 & zmask(iin,ijn,:,iobs)) 397 350 398 351 ENDIF … … 400 353 CALL obs_level_search(kpk, & 401 354 & zgdept(iin,ijn,:,iobs),& 402 & inum_obs, prodatqc%var( 1)%vdep(ista:iend), &355 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 403 356 & iv_indic) 404 357 405 358 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 406 & prodatqc%var( 1)%vdep(ista:iend), &407 & zint 1(iin,ijn,:,iobs), &359 & prodatqc%var(kvar)%vdep(ista:iend), & 360 & zint(iin,ijn,:,iobs), & 408 361 & zobs2k,interp_corner(iin,ijn,:), & 409 362 & zgdept(iin,ijn,:,iobs), & 410 & zmask 1(iin,ijn,:,iobs) )363 & zmask(iin,ijn,:,iobs) ) 411 364 412 365 ENDDO … … 432 385 DO ijn=1,2 433 386 434 depth_loop 1: DO ik=kpk,2,-1435 IF(zmask 1(iin,ijn,ik-1,iobs ) > 0.9 )THEN387 depth_loop: DO ik=kpk,2,-1 388 IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN 436 389 437 390 zweig(iin,ijn,1) = & 438 391 & zweig1(iin,ijn,1) * & 439 392 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 440 & - prodatqc%var( 1)%vdep(iend)),0._wp)393 & - prodatqc%var(kvar)%vdep(iend)),0._wp) 441 394 442 EXIT depth_loop 1395 EXIT depth_loop 443 396 444 397 ENDIF 445 398 446 ENDDO depth_loop 1399 ENDDO depth_loop 447 400 448 401 ENDDO … … 450 403 451 404 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 452 & prodatqc%var( 1)%vmod(iend:iend) )405 & prodatqc%var(kvar)%vmod(iend:iend) ) 453 406 454 407 ! Set QC flag for any observations found below the bottom 455 408 ! needed as the check here is more strict than that in obs_prep 456 IF (sum(zweig) == 0.0_wp) prodatqc%var( 1)%nvqc(iend:iend)=4409 IF (sum(zweig) == 0.0_wp) prodatqc%var(kvar)%nvqc(iend:iend)=4 457 410 458 411 ENDDO … … 460 413 DEALLOCATE(interp_corner,iv_indic) 461 414 462 ENDIF 463 464 ! For the second variable 465 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 466 467 zobsk(:) = obfillflt 468 469 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 470 471 IF ( idayend == 0 ) THEN 472 ! Daily averaged data 473 474 ! vertically interpolate all 4 corners 475 ista = prodatqc%npvsta(jobs,2) 476 iend = prodatqc%npvend(jobs,2) 477 inum_obs = iend - ista + 1 478 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 479 480 DO iin=1,2 481 DO ijn=1,2 482 483 IF ( k1dint == 1 ) THEN 484 CALL obs_int_z1d_spl( kpk, & 485 & zinm2(iin,ijn,:,iobs), & 486 & zobs2k, zgdept(iin,ijn,:,iobs), & 487 & zmask2(iin,ijn,:,iobs)) 488 ENDIF 489 490 CALL obs_level_search(kpk, & 491 & zgdept(iin,ijn,:,iobs), & 492 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 493 & iv_indic) 494 495 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 496 & prodatqc%var(2)%vdep(ista:iend), & 497 & zinm2(iin,ijn,:,iobs), & 498 & zobs2k, interp_corner(iin,ijn,:), & 499 & zgdept(iin,ijn,:,iobs), & 500 & zmask2(iin,ijn,:,iobs)) 501 502 ENDDO 503 ENDDO 504 505 ENDIF !idayend 506 507 ELSE 508 509 ! Point data 510 511 ! vertically interpolate all 4 corners 512 ista = prodatqc%npvsta(jobs,2) 513 iend = prodatqc%npvend(jobs,2) 514 inum_obs = iend - ista + 1 515 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 516 DO iin=1,2 517 DO ijn=1,2 518 519 IF ( k1dint == 1 ) THEN 520 CALL obs_int_z1d_spl( kpk, & 521 & zint2(iin,ijn,:,iobs),& 522 & zobs2k, zgdept(iin,ijn,:,iobs), & 523 & zmask2(iin,ijn,:,iobs)) 524 525 ENDIF 526 527 CALL obs_level_search(kpk, & 528 & zgdept(iin,ijn,:,iobs),& 529 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 530 & iv_indic) 531 532 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 533 & prodatqc%var(2)%vdep(ista:iend), & 534 & zint2(iin,ijn,:,iobs), & 535 & zobs2k,interp_corner(iin,ijn,:), & 536 & zgdept(iin,ijn,:,iobs), & 537 & zmask2(iin,ijn,:,iobs) ) 538 539 ENDDO 540 ENDDO 541 542 ENDIF 543 544 !------------------------------------------------------------- 545 ! Compute the horizontal interpolation for every profile level 546 !------------------------------------------------------------- 547 548 DO ikn=1,inum_obs 549 iend=ista+ikn-1 550 551 zweig(:,:,1) = 0._wp 552 553 ! This code forces the horizontal weights to be 554 ! zero IF the observation is below the bottom of the 555 ! corners of the interpolation nodes, Or if it is in 556 ! the mask. This is important for observations near 557 ! steep bathymetry 558 DO iin=1,2 559 DO ijn=1,2 560 561 depth_loop2: DO ik=kpk,2,-1 562 IF(zmask2(iin,ijn,ik-1,iobs ) > 0.9 )THEN 563 564 zweig(iin,ijn,1) = & 565 & zweig2(iin,ijn,1) * & 566 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 567 & - prodatqc%var(2)%vdep(iend)),0._wp) 568 569 EXIT depth_loop2 570 571 ENDIF 572 573 ENDDO depth_loop2 574 575 ENDDO 576 ENDDO 577 578 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 579 & prodatqc%var(2)%vmod(iend:iend) ) 580 581 ! Set QC flag for any observations found below the bottom 582 ! needed as the check here is more strict than that in obs_prep 583 IF (sum(zweig) == 0.0_wp) prodatqc%var(2)%nvqc(iend:iend)=4 584 585 ENDDO 586 587 DEALLOCATE(interp_corner,iv_indic) 588 589 ENDIF 415 ENDIF 590 416 591 417 ENDDO 592 418 593 419 ! Deallocate the data for interpolation 594 DEALLOCATE( & 595 & igrdi1, & 596 & igrdi2, & 597 & igrdj1, & 598 & igrdj2, & 599 & zglam1, & 600 & zglam2, & 601 & zgphi1, & 602 & zgphi2, & 603 & zmask1, & 604 & zmask2, & 605 & zint1, & 606 & zint2, & 420 DEALLOCATE( & 421 & igrdi, & 422 & igrdj, & 423 & zglam, & 424 & zgphi, & 425 & zmask, & 426 & zint, & 607 427 & zgdept, & 608 428 & zgdepw & … … 611 431 ! At the end of the day also get interpolated means 612 432 IF ( ld_dailyav .AND. idayend == 0 ) THEN 613 DEALLOCATE( & 614 & zinm1, & 615 & zinm2 & 616 & ) 433 DEALLOCATE( zinm ) 617 434 ENDIF 618 435 619 prodatqc%nprofup = prodatqc%nprofup + ipro 436 IF ( kvar == prodatqc%nvar ) THEN 437 prodatqc%nprofup = prodatqc%nprofup + ipro 438 ENDIF 620 439 621 440 END SUBROUTINE obs_prof_opt -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_prep.F90
r12489 r14062 241 241 242 242 243 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var 1, ld_var2, &243 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 244 244 & kpi, kpj, kpk, & 245 & zmask 1, pglam1, pgphi1, zmask2, pglam2, pgphi2, &245 & zmask, pglam, pgphi, & 246 246 & ld_nea, ld_bound_reject, Kmm, kdailyavtypes, kqc_cutoff ) 247 247 … … 269 269 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 270 270 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 271 LOGICAL, INTENT(IN) :: ld_var1 ! Observed variables switches272 LOGICAL, INTENT(IN) :: ld_var2271 LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 272 & ld_var ! Observed variables switches 273 273 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 274 274 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary … … 277 277 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 278 278 & kdailyavtypes ! Types for daily averages 279 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 280 & zmask1, & 281 & zmask2 282 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 283 & pglam1, & 284 & pglam2, & 285 & pgphi1, & 286 & pgphi2 279 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 280 & zmask 281 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 282 & pglam, & 283 & pgphi 287 284 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 288 285 … … 295 292 INTEGER :: imin0 296 293 INTEGER :: icycle ! Current assimilation cycle 297 ! Counters for observations that are 298 INTEGER :: iotdobs ! - outside time domain 299 INTEGER :: iosdv1obs ! - outside space domain (variable 1) 300 INTEGER :: iosdv2obs ! - outside space domain (variable 2) 301 INTEGER :: ilanv1obs ! - within a model land cell (variable 1) 302 INTEGER :: ilanv2obs ! - within a model land cell (variable 2) 303 INTEGER :: inlav1obs ! - close to land (variable 1) 304 INTEGER :: inlav2obs ! - close to land (variable 2) 305 INTEGER :: ibdyv1obs ! - boundary (variable 1) 306 INTEGER :: ibdyv2obs ! - boundary (variable 2) 307 INTEGER :: igrdobs ! - fail the grid search 308 INTEGER :: iuvchku ! - reject u if v rejected and vice versa 309 INTEGER :: iuvchkv ! 310 ! Global counters for observations that are 311 INTEGER :: iotdobsmpp ! - outside time domain 312 INTEGER :: iosdv1obsmpp ! - outside space domain (variable 1) 313 INTEGER :: iosdv2obsmpp ! - outside space domain (variable 2) 314 INTEGER :: ilanv1obsmpp ! - within a model land cell (variable 1) 315 INTEGER :: ilanv2obsmpp ! - within a model land cell (variable 2) 316 INTEGER :: inlav1obsmpp ! - close to land (variable 1) 317 INTEGER :: inlav2obsmpp ! - close to land (variable 2) 318 INTEGER :: ibdyv1obsmpp ! - boundary (variable 1) 319 INTEGER :: ibdyv2obsmpp ! - boundary (variable 2) 320 INTEGER :: igrdobsmpp ! - fail the grid search 321 INTEGER :: iuvchkumpp ! - reject var1 if var2 rejected and vice versa 322 INTEGER :: iuvchkvmpp ! 294 ! Counters for observations that are 295 INTEGER :: iotdobs ! - outside time domain 296 INTEGER, DIMENSION(profdata%nvar) :: iosdvobs ! - outside space domain 297 INTEGER, DIMENSION(profdata%nvar) :: ilanvobs ! - within a model land cell 298 INTEGER, DIMENSION(profdata%nvar) :: inlavobs ! - close to land 299 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs ! - boundary 300 INTEGER :: igrdobs ! - fail the grid search 301 INTEGER :: iuvchku ! - reject UVEL if VVEL rejected 302 INTEGER :: iuvchkv ! - reject VVEL if UVEL rejected 303 ! Global counters for observations that are 304 INTEGER :: iotdobsmpp ! - outside time domain 305 INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp ! - outside space domain 306 INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp ! - within a model land cell 307 INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp ! - close to land 308 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp ! - boundary 309 INTEGER :: igrdobsmpp ! - fail the grid search 310 INTEGER :: iuvchkumpp ! - reject UVEL if VVEL rejected 311 INTEGER :: iuvchkvmpp ! - reject VVEL if UVEL rejected 323 312 TYPE(obs_prof_valid) :: llvalid ! Profile selection 324 313 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 325 & llvvalid ! var 1,var2selection314 & llvvalid ! var selection 326 315 INTEGER :: jvar ! Variable loop variable 327 316 INTEGER :: jobs ! Obs. loop variable 328 317 INTEGER :: jstp ! Time loop variable 329 318 INTEGER :: inrc ! Time index variable 319 CHARACTER(LEN=256) :: cout1 ! Diagnostic output line 320 CHARACTER(LEN=256) :: cout2 ! Diagnostic output line 330 321 !!---------------------------------------------------------------------- 331 322 … … 342 333 icycle = nn_no ! Assimilation cycle 343 334 344 ! Diagnotics counters for various failures. 345 346 iotdobs = 0 347 igrdobs = 0 348 iosdv1obs = 0 349 iosdv2obs = 0 350 ilanv1obs = 0 351 ilanv2obs = 0 352 inlav1obs = 0 353 inlav2obs = 0 354 ibdyv1obs = 0 355 ibdyv2obs = 0 356 iuvchku = 0 357 iuvchkv = 0 335 ! Diagnostic counters for various failures. 336 337 iotdobs = 0 338 igrdobs = 0 339 iosdvobs(:) = 0 340 ilanvobs(:) = 0 341 inlavobs(:) = 0 342 ibdyvobs(:) = 0 343 iuvchku = 0 344 iuvchkv = 0 358 345 359 346 … … 388 375 ! ----------------------------------------------------------------------- 389 376 390 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,1), profdata%mj(:,1), &391 & profdata%nqc, igrdobs )392 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,2), profdata%mj(:,2), &393 & profdata%nqc, igrdobs )377 DO jvar = 1, profdata%nvar 378 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,jvar), profdata%mj(:,jvar), & 379 & profdata%nqc, igrdobs ) 380 END DO 394 381 395 382 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) … … 406 393 ! ----------------------------------------------------------------------- 407 394 408 ! Variable 1 409 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & 410 & profdata%npvsta(:,1), profdata%npvend(:,1), & 411 & jpi, jpj, & 412 & jpk, & 413 & profdata%mi, profdata%mj, & 414 & profdata%var(1)%mvk, & 415 & profdata%rlam, profdata%rphi, & 416 & profdata%var(1)%vdep, & 417 & pglam1, pgphi1, & 418 & gdept_1d, zmask1, & 419 & profdata%nqc, profdata%var(1)%nvqc, & 420 & iosdv1obs, ilanv1obs, & 421 & inlav1obs, ld_nea, & 422 & ibdyv1obs, ld_bound_reject, & 423 & iqc_cutoff, Kmm ) 424 425 CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 426 CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 427 CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 428 CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 429 430 ! Variable 2 431 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & 432 & profdata%npvsta(:,2), profdata%npvend(:,2), & 433 & jpi, jpj, & 434 & jpk, & 435 & profdata%mi, profdata%mj, & 436 & profdata%var(2)%mvk, & 437 & profdata%rlam, profdata%rphi, & 438 & profdata%var(2)%vdep, & 439 & pglam2, pgphi2, & 440 & gdept_1d, zmask2, & 441 & profdata%nqc, profdata%var(2)%nvqc, & 442 & iosdv2obs, ilanv2obs, & 443 & inlav2obs, ld_nea, & 444 & ibdyv2obs, ld_bound_reject, & 445 & iqc_cutoff, Kmm ) 446 447 CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 448 CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 449 CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 450 CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 395 DO jvar = 1, profdata%nvar 396 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(jvar), & 397 & profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 398 & jpi, jpj, & 399 & jpk, & 400 & profdata%mi, profdata%mj, & 401 & profdata%var(jvar)%mvk, & 402 & profdata%rlam, profdata%rphi, & 403 & profdata%var(jvar)%vdep, & 404 & pglam(:,:,jvar), pgphi(:,:,jvar), & 405 & gdept_1d, zmask(:,:,:,jvar), & 406 & profdata%nqc, profdata%var(jvar)%nvqc, & 407 & iosdvobs(jvar), ilanvobs(jvar), & 408 & inlavobs(jvar), ld_nea, & 409 & ibdyvobs(jvar), ld_bound_reject, & 410 & iqc_cutoff, Kmm ) 411 412 CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 413 CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 414 CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 415 CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 416 END DO 451 417 452 418 ! ----------------------------------------------------------------------- … … 499 465 500 466 WRITE(numout,*) 501 WRITE(numout,*) ' Profiles outside time domain = ', &467 WRITE(numout,*) ' Profiles outside time domain = ', & 502 468 & iotdobsmpp 503 WRITE(numout,*) ' Remaining profiles that failed grid search = ', &469 WRITE(numout,*) ' Remaining profiles that failed grid search = ', & 504 470 & igrdobsmpp 505 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain = ', & 506 & iosdv1obsmpp 507 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points = ', & 508 & ilanv1obsmpp 509 IF (ld_nea) THEN 510 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 511 & inlav1obsmpp 512 ELSE 513 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept) = ',& 514 & inlav1obsmpp 515 ENDIF 516 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 517 WRITE(numout,*) ' U observation rejected since V rejected = ', & 518 & iuvchku 519 ENDIF 520 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 521 & ibdyv1obsmpp 522 WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted = ', & 523 & prodatqc%nvprotmpp(1) 524 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain = ', & 525 & iosdv2obsmpp 526 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points = ', & 527 & ilanv2obsmpp 528 IF (ld_nea) THEN 529 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 530 & inlav2obsmpp 531 ELSE 532 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept) = ',& 533 & inlav2obsmpp 534 ENDIF 535 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 536 WRITE(numout,*) ' V observation rejected since U rejected = ', & 537 & iuvchkv 538 ENDIF 539 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 540 & ibdyv2obsmpp 541 WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted = ', & 542 & prodatqc%nvprotmpp(2) 471 DO jvar = 1, profdata%nvar 472 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain = ', & 473 & iosdvobsmpp(jvar) 474 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points = ', & 475 & ilanvobsmpp(jvar) 476 IF (ld_nea) THEN 477 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 478 & inlavobsmpp(jvar) 479 ELSE 480 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept) = ',& 481 & inlavobsmpp(jvar) 482 ENDIF 483 IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 484 WRITE(numout,*) ' U observation rejected since V rejected = ', & 485 & iuvchku 486 ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 487 WRITE(numout,*) ' V observation rejected since U rejected = ', & 488 & iuvchkv 489 ENDIF 490 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 491 & ibdyvobsmpp(jvar) 492 WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted = ', & 493 & prodatqc%nvprotmpp(jvar) 494 END DO 543 495 544 496 WRITE(numout,*) 545 497 WRITE(numout,*) ' Number of observations per time step :' 546 498 WRITE(numout,*) 547 WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 548 & ' '//prodatqc%cvars(1)//' ', & 549 & ' '//prodatqc%cvars(2)//' ' 550 WRITE(numout,998) 499 WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 500 WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 501 DO jvar = 1, prodatqc%nvar 502 WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 503 WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 504 END DO 505 WRITE(numout,*) cout1 506 WRITE(numout,*) cout2 551 507 ENDIF 552 508 … … 575 531 DO jstp = nit000 - 1, nitend 576 532 inrc = jstp - nit000 + 2 577 WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 578 & prodatqc%nvstpmpp(inrc,1), & 579 & prodatqc%nvstpmpp(inrc,2) 533 WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 534 DO jvar = 1, prodatqc%nvar 535 WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 536 END DO 537 WRITE(numout,*) cout1 580 538 END DO 581 539 ENDIF 582 583 998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------')584 999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8)585 540 586 541 END SUBROUTINE obs_pre_prof -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_read_prof.F90
r13226 r14062 45 45 SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & 46 46 & kvars, kextr, kstp, ddobsini, ddobsend, & 47 & ldvar 1, ldvar2, ldignmis, ldsatt, &48 & ldmod, kdailyavtypes )47 & ldvar, ldignmis, ldsatt, & 48 & ldmod, cdvars, kdailyavtypes ) 49 49 !!--------------------------------------------------------------------- 50 50 !! … … 74 74 INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var 75 75 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 76 LOGICAL, INTENT(IN) :: ldvar1 ! Observed variables switches 77 LOGICAL, INTENT(IN) :: ldvar2 76 LOGICAL, DIMENSION(kvars), INTENT(IN) :: ldvar ! Observed variables switches 78 77 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 79 78 LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points … … 81 80 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 82 81 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 82 CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 83 83 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 84 84 & kdailyavtypes ! Types of daily average observations … … 87 87 CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' 88 88 CHARACTER(len=8) :: clrefdate 89 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 89 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin 90 90 INTEGER :: jvar 91 91 INTEGER :: ji … … 105 105 INTEGER :: iprof 106 106 INTEGER :: iproftot 107 INTEGER :: ivar1t0 108 INTEGER :: ivar2t0 109 INTEGER :: ivar1t 110 INTEGER :: ivar2t 107 INTEGER, DIMENSION(kvars) :: ivart0 108 INTEGER, DIMENSION(kvars) :: ivart 111 109 INTEGER :: ip3dt 112 110 INTEGER :: ios 113 111 INTEGER :: ioserrcount 114 INTEGER :: ivar1tmpp 115 INTEGER :: ivar2tmpp 112 INTEGER, DIMENSION(kvars) :: ivartmpp 116 113 INTEGER :: ip3dtmpp 117 114 INTEGER :: itype 118 115 INTEGER, DIMENSION(knumfiles) :: & 119 116 & irefdate 120 INTEGER, DIMENSION(ntyp1770+1) :: & 121 & itypvar1, & 122 & itypvar1mpp, & 123 & itypvar2, & 124 & itypvar2mpp 117 INTEGER, DIMENSION(ntyp1770+1,kvars) :: & 118 & itypvar, & 119 & itypvarmpp 120 INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 121 & iobsi, & 122 & iobsj, & 123 & iproc 125 124 INTEGER, DIMENSION(:), ALLOCATABLE :: & 126 & iobsi1, &127 & iobsj1, &128 & iproc1, &129 & iobsi2, &130 & iobsj2, &131 & iproc2, &132 125 & iindx, & 133 126 & ifileidx, & … … 147 140 LOGICAL :: llvalprof 148 141 LOGICAL :: lldavtimset 142 LOGICAL :: llcycle 149 143 TYPE(obfbdata), POINTER, DIMENSION(:) :: & 150 144 & inpfiles … … 152 146 ! Local initialization 153 147 iprof = 0 154 ivar1t0 = 0 155 ivar2t0 = 0 148 ivart0(:) = 0 156 149 ip3dt = 0 157 150 … … 219 212 & ldgrid = .TRUE. ) 220 213 221 IF ( inpfiles(jj)%nvar < 2) THEN214 IF ( inpfiles(jj)%nvar /= kvars ) THEN 222 215 CALL ctl_stop( 'Feedback format error: ', & 223 & ' less than 2vars in profile file' )216 & ' unexpected number of vars in profile file' ) 224 217 ENDIF 225 218 … … 229 222 230 223 IF ( jj == 1 ) THEN 231 ALLOCATE( clvars ( inpfiles(jj)%nvar ) )224 ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 232 225 DO ji = 1, inpfiles(jj)%nvar 233 clvars(ji) = inpfiles(jj)%cname(ji) 226 clvarsin(ji) = inpfiles(jj)%cname(ji) 227 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 228 CALL ctl_stop( 'Feedback file variables do not match', & 229 & ' expected variable names for this type' ) 230 ENDIF 234 231 END DO 235 232 ELSE 236 233 DO ji = 1, inpfiles(jj)%nvar 237 IF ( inpfiles(jj)%cname(ji) /= clvars (ji) ) THEN234 IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 238 235 CALL ctl_stop( 'Feedback file variables not consistent', & 239 236 & ' with previous files for this type' ) … … 308 305 DO ji = 1, inpfiles(jj)%nobs 309 306 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 310 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 311 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 307 llcycle = .TRUE. 308 DO jvar = 1, kvars 309 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 310 llcycle = .FALSE. 311 EXIT 312 ENDIF 313 END DO 314 IF ( llcycle ) CYCLE 312 315 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 313 316 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 317 320 ALLOCATE( zlam(inowin) ) 318 321 ALLOCATE( zphi(inowin) ) 319 ALLOCATE( iobsi1(inowin) ) 320 ALLOCATE( iobsj1(inowin) ) 321 ALLOCATE( iproc1(inowin) ) 322 ALLOCATE( iobsi2(inowin) ) 323 ALLOCATE( iobsj2(inowin) ) 324 ALLOCATE( iproc2(inowin) ) 322 ALLOCATE( iobsi(inowin,kvars) ) 323 ALLOCATE( iobsj(inowin,kvars) ) 324 ALLOCATE( iproc(inowin,kvars) ) 325 325 inowin = 0 326 326 DO ji = 1, inpfiles(jj)%nobs 327 327 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 328 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 329 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 328 llcycle = .TRUE. 329 DO jvar = 1, kvars 330 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 331 llcycle = .FALSE. 332 EXIT 333 ENDIF 334 END DO 335 IF ( llcycle ) CYCLE 330 336 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 331 337 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 336 342 END DO 337 343 338 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 339 CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 340 & iproc1, 'T' ) 341 iobsi2(:) = iobsi1(:) 342 iobsj2(:) = iobsj1(:) 343 iproc2(:) = iproc1(:) 344 ELSEIF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 345 CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 346 & iproc1, 'U' ) 347 CALL obs_grid_search( inowin, zlam, zphi, iobsi2, iobsj2, & 348 & iproc2, 'V' ) 344 ! Assume anything other than velocity is on T grid 345 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 346 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 347 & iproc(:,1), 'U' ) 348 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,2), iobsj(:,2), & 349 & iproc(:,2), 'V' ) 350 ELSE 351 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 352 & iproc(:,1), 'T' ) 353 IF ( kvars > 1 ) THEN 354 DO jvar = 2, kvars 355 iobsi(:,jvar) = iobsi(:,1) 356 iobsj(:,jvar) = iobsj(:,1) 357 iproc(:,jvar) = iproc(:,1) 358 END DO 359 ENDIF 349 360 ENDIF 350 361 … … 352 363 DO ji = 1, inpfiles(jj)%nobs 353 364 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 354 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 355 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 365 llcycle = .TRUE. 366 DO jvar = 1, kvars 367 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 368 llcycle = .FALSE. 369 EXIT 370 ENDIF 371 END DO 372 IF ( llcycle ) CYCLE 356 373 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 357 374 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 358 375 inowin = inowin + 1 359 inpfiles(jj)%iproc(ji,1) = iproc1(inowin) 360 inpfiles(jj)%iobsi(ji,1) = iobsi1(inowin) 361 inpfiles(jj)%iobsj(ji,1) = iobsj1(inowin) 362 inpfiles(jj)%iproc(ji,2) = iproc2(inowin) 363 inpfiles(jj)%iobsi(ji,2) = iobsi2(inowin) 364 inpfiles(jj)%iobsj(ji,2) = iobsj2(inowin) 365 IF ( inpfiles(jj)%iproc(ji,1) /= & 366 & inpfiles(jj)%iproc(ji,2) ) THEN 367 CALL ctl_stop( 'Error in obs_read_prof:', & 368 & 'var1 and var2 observation on different processors') 376 DO jvar = 1, kvars 377 inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) 378 inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) 379 inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) 380 END DO 381 IF ( kvars > 1 ) THEN 382 DO jvar = 2, kvars 383 IF ( inpfiles(jj)%iproc(ji,jvar) /= & 384 & inpfiles(jj)%iproc(ji,1) ) THEN 385 CALL ctl_stop( 'Error in obs_read_prof:', & 386 & 'observation on different processors for different vars') 387 ENDIF 388 END DO 369 389 ENDIF 370 390 ENDIF 371 391 END DO 372 DEALLOCATE( zlam, zphi, iobsi 1, iobsj1, iproc1, iobsi2, iobsj2, iproc2)392 DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) 373 393 374 394 DO ji = 1, inpfiles(jj)%nobs 375 395 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 376 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 377 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 396 llcycle = .TRUE. 397 DO jvar = 1, kvars 398 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 399 llcycle = .FALSE. 400 EXIT 401 ENDIF 402 END DO 403 IF ( llcycle ) CYCLE 378 404 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 379 405 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 384 410 ENDIF 385 411 llvalprof = .FALSE. 386 IF ( ldvar1 ) THEN 387 loop_t_count : DO ij = 1,inpfiles(jj)%nlev 388 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 389 & CYCLE 390 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 391 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 392 ivar1t0 = ivar1t0 + 1 393 ENDIF 394 END DO loop_t_count 395 ENDIF 396 IF ( ldvar2 ) THEN 397 loop_s_count : DO ij = 1,inpfiles(jj)%nlev 398 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 399 & CYCLE 400 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 401 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 402 ivar2t0 = ivar2t0 + 1 403 ENDIF 404 END DO loop_s_count 405 ENDIF 406 loop_p_count : DO ij = 1,inpfiles(jj)%nlev 412 DO jvar = 1, kvars 413 IF ( ldvar(jvar) ) THEN 414 DO ij = 1,inpfiles(jj)%nlev 415 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 416 & CYCLE 417 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 418 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 419 ivart0(jvar) = ivart0(jvar) + 1 420 ENDIF 421 END DO 422 ENDIF 423 END DO 424 DO ij = 1,inpfiles(jj)%nlev 407 425 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 408 426 & CYCLE 409 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &410 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &411 & ldvar1 ) .OR. &412 & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. &413 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &414 & ldvar2 ) ) THEN415 ip3dt = ip3dt + 1416 llvalprof = .TRUE.417 END IF418 END DO loop_p_count427 DO jvar = 1, kvars 428 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 429 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 430 & ldvar(jvar) ) ) THEN 431 ip3dt = ip3dt + 1 432 llvalprof = .TRUE. 433 EXIT 434 ENDIF 435 END DO 436 END DO 419 437 420 438 IF ( llvalprof ) iprof = iprof + 1 … … 438 456 DO ji = 1, inpfiles(jj)%nobs 439 457 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 440 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 441 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 458 llcycle = .TRUE. 459 DO jvar = 1, kvars 460 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 461 llcycle = .FALSE. 462 EXIT 463 ENDIF 464 END DO 465 IF ( llcycle ) CYCLE 442 466 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 443 467 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 453 477 DO ji = 1, inpfiles(jj)%nobs 454 478 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 455 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 456 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 479 llcycle = .TRUE. 480 DO jvar = 1, kvars 481 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 482 llcycle = .FALSE. 483 EXIT 484 ENDIF 485 END DO 486 IF ( llcycle ) CYCLE 457 487 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 458 488 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 470 500 iv3dt(:) = -1 471 501 IF (ldsatt) THEN 472 iv3dt(1) = ip3dt 473 iv3dt(2) = ip3dt 502 iv3dt(:) = ip3dt 474 503 ELSE 475 iv3dt(1) = ivar1t0 476 iv3dt(2) = ivar2t0 504 iv3dt(:) = ivart0(:) 477 505 ENDIF 478 506 CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & … … 483 511 profdata%nprof = 0 484 512 profdata%nvprot(:) = 0 485 profdata%cvars(:) = clvars (:)513 profdata%cvars(:) = clvarsin(:) 486 514 iprof = 0 487 515 488 516 ip3dt = 0 489 ivar1t = 0 490 ivar2t = 0 491 itypvar1 (:) = 0 492 itypvar1mpp(:) = 0 493 494 itypvar2 (:) = 0 495 itypvar2mpp(:) = 0 517 ivart(:) = 0 518 itypvar (:,:) = 0 519 itypvarmpp(:,:) = 0 496 520 497 521 ioserrcount = 0 … … 501 525 ji = iprofidx(iindx(jk)) 502 526 503 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 504 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 505 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 527 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 528 llcycle = .TRUE. 529 DO jvar = 1, kvars 530 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 531 llcycle = .FALSE. 532 EXIT 533 ENDIF 534 END DO 535 IF ( llcycle ) CYCLE 506 536 507 537 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & … … 519 549 520 550 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 521 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 522 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 551 llcycle = .TRUE. 552 DO jvar = 1, kvars 553 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 554 llcycle = .FALSE. 555 EXIT 556 ENDIF 557 END DO 558 IF ( llcycle ) CYCLE 523 559 524 560 loop_prof : DO ij = 1, inpfiles(jj)%nlev … … 527 563 & CYCLE 528 564 529 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 530 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 531 532 llvalprof = .TRUE. 533 EXIT loop_prof 534 535 ENDIF 536 537 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 538 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 539 540 llvalprof = .TRUE. 541 EXIT loop_prof 542 543 ENDIF 565 DO jvar = 1, kvars 566 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 567 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 568 569 llvalprof = .TRUE. 570 EXIT loop_prof 571 572 ENDIF 573 END DO 544 574 545 575 END DO loop_prof … … 573 603 574 604 ! Coordinate search parameters 575 profdata%mi (iprof,1) = inpfiles(jj)%iobsi(ji,1)576 profdata%mj (iprof,1) = inpfiles(jj)%iobsj(ji,1)577 profdata%mi (iprof,2) = inpfiles(jj)%iobsi(ji,2)578 profdata%mj (iprof,2) = inpfiles(jj)%iobsj(ji,2)605 DO jvar = 1, kvars 606 profdata%mi (iprof,jvar) = inpfiles(jj)%iobsi(ji,jvar) 607 profdata%mj (iprof,jvar) = inpfiles(jj)%iobsj(ji,jvar) 608 END DO 579 609 580 610 ! Profile WMO number … … 616 646 IF (ldsatt) THEN 617 647 618 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 619 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 620 & ldvar1 ) .OR. & 621 & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 622 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 623 & ldvar2 ) ) THEN 624 ip3dt = ip3dt + 1 625 ELSE 626 CYCLE 648 DO jvar = 1, kvars 649 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 650 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 651 & ldvar(jvar) ) ) THEN 652 ip3dt = ip3dt + 1 653 EXIT 654 ELSE IF ( jvar == kvars ) THEN 655 CYCLE loop_p 656 ENDIF 657 END DO 658 659 ENDIF 660 661 DO jvar = 1, kvars 662 663 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 664 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 665 & ldvar(jvar) ) .OR. ldsatt ) THEN 666 667 IF (ldsatt) THEN 668 669 ivart(jvar) = ip3dt 670 671 ELSE 672 673 ivart(jvar) = ivart(jvar) + 1 674 675 ENDIF 676 677 ! Depth of jvar observation 678 profdata%var(jvar)%vdep(ivart(jvar)) = & 679 & inpfiles(jj)%pdep(ij,ji) 680 681 ! Depth of jvar observation QC 682 profdata%var(jvar)%idqc(ivart(jvar)) = & 683 & inpfiles(jj)%idqc(ij,ji) 684 685 ! Depth of jvar observation QC flags 686 profdata%var(jvar)%idqcf(:,ivart(jvar)) = & 687 & inpfiles(jj)%idqcf(:,ij,ji) 688 689 ! Profile index 690 profdata%var(jvar)%nvpidx(ivart(jvar)) = iprof 691 692 ! Vertical index in original profile 693 profdata%var(jvar)%nvlidx(ivart(jvar)) = ij 694 695 ! Profile jvar value 696 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 697 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 698 profdata%var(jvar)%vobs(ivart(jvar)) = & 699 & inpfiles(jj)%pob(ij,ji,jvar) 700 IF ( ldmod ) THEN 701 profdata%var(jvar)%vmod(ivart(jvar)) = & 702 & inpfiles(jj)%padd(ij,ji,1,jvar) 703 ENDIF 704 ! Count number of profile var1 data as function of type 705 itypvar( profdata%ntyp(iprof) + 1, jvar ) = & 706 & itypvar( profdata%ntyp(iprof) + 1, jvar ) + 1 707 ELSE 708 profdata%var(jvar)%vobs(ivart(jvar)) = fbrmdi 709 ENDIF 710 711 ! Profile jvar qc 712 profdata%var(jvar)%nvqc(ivart(jvar)) = & 713 & inpfiles(jj)%ivlqc(ij,ji,jvar) 714 715 ! Profile jvar qc flags 716 profdata%var(jvar)%nvqcf(:,ivart(jvar)) = & 717 & inpfiles(jj)%ivlqcf(:,ij,ji,jvar) 718 719 ! Profile insitu T value 720 IF ( TRIM( inpfiles(jj)%cname(jvar) ) == 'POTM' ) THEN 721 profdata%var(jvar)%vext(ivart(jvar),1) = & 722 & inpfiles(jj)%pext(ij,ji,1) 723 ENDIF 724 627 725 ENDIF 628 629 ENDIF 630 631 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 632 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 633 & ldvar1 ) .OR. ldsatt ) THEN 634 635 IF (ldsatt) THEN 636 637 ivar1t = ip3dt 638 639 ELSE 640 641 ivar1t = ivar1t + 1 642 643 ENDIF 644 645 ! Depth of var1 observation 646 profdata%var(1)%vdep(ivar1t) = & 647 & inpfiles(jj)%pdep(ij,ji) 648 649 ! Depth of var1 observation QC 650 profdata%var(1)%idqc(ivar1t) = & 651 & inpfiles(jj)%idqc(ij,ji) 652 653 ! Depth of var1 observation QC flags 654 profdata%var(1)%idqcf(:,ivar1t) = & 655 & inpfiles(jj)%idqcf(:,ij,ji) 656 657 ! Profile index 658 profdata%var(1)%nvpidx(ivar1t) = iprof 659 660 ! Vertical index in original profile 661 profdata%var(1)%nvlidx(ivar1t) = ij 662 663 ! Profile var1 value 664 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 665 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 666 profdata%var(1)%vobs(ivar1t) = & 667 & inpfiles(jj)%pob(ij,ji,1) 668 IF ( ldmod ) THEN 669 profdata%var(1)%vmod(ivar1t) = & 670 & inpfiles(jj)%padd(ij,ji,1,1) 671 ENDIF 672 ! Count number of profile var1 data as function of type 673 itypvar1( profdata%ntyp(iprof) + 1 ) = & 674 & itypvar1( profdata%ntyp(iprof) + 1 ) + 1 675 ELSE 676 profdata%var(1)%vobs(ivar1t) = fbrmdi 677 ENDIF 678 679 ! Profile var1 qc 680 profdata%var(1)%nvqc(ivar1t) = & 681 & inpfiles(jj)%ivlqc(ij,ji,1) 682 683 ! Profile var1 qc flags 684 profdata%var(1)%nvqcf(:,ivar1t) = & 685 & inpfiles(jj)%ivlqcf(:,ij,ji,1) 686 687 ! Profile insitu T value 688 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 689 profdata%var(1)%vext(ivar1t,1) = & 690 & inpfiles(jj)%pext(ij,ji,1) 691 ENDIF 692 693 ENDIF 694 695 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 696 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 697 & ldvar2 ) .OR. ldsatt ) THEN 698 699 IF (ldsatt) THEN 700 701 ivar2t = ip3dt 702 703 ELSE 704 705 ivar2t = ivar2t + 1 706 707 ENDIF 708 709 ! Depth of var2 observation 710 profdata%var(2)%vdep(ivar2t) = & 711 & inpfiles(jj)%pdep(ij,ji) 712 713 ! Depth of var2 observation QC 714 profdata%var(2)%idqc(ivar2t) = & 715 & inpfiles(jj)%idqc(ij,ji) 716 717 ! Depth of var2 observation QC flags 718 profdata%var(2)%idqcf(:,ivar2t) = & 719 & inpfiles(jj)%idqcf(:,ij,ji) 720 721 ! Profile index 722 profdata%var(2)%nvpidx(ivar2t) = iprof 723 724 ! Vertical index in original profile 725 profdata%var(2)%nvlidx(ivar2t) = ij 726 727 ! Profile var2 value 728 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) ) .AND. & 729 & ( .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) ) THEN 730 profdata%var(2)%vobs(ivar2t) = & 731 & inpfiles(jj)%pob(ij,ji,2) 732 IF ( ldmod ) THEN 733 profdata%var(2)%vmod(ivar2t) = & 734 & inpfiles(jj)%padd(ij,ji,1,2) 735 ENDIF 736 ! Count number of profile var2 data as function of type 737 itypvar2( profdata%ntyp(iprof) + 1 ) = & 738 & itypvar2( profdata%ntyp(iprof) + 1 ) + 1 739 ELSE 740 profdata%var(2)%vobs(ivar2t) = fbrmdi 741 ENDIF 742 743 ! Profile var2 qc 744 profdata%var(2)%nvqc(ivar2t) = & 745 & inpfiles(jj)%ivlqc(ij,ji,2) 746 747 ! Profile var2 qc flags 748 profdata%var(2)%nvqcf(:,ivar2t) = & 749 & inpfiles(jj)%ivlqcf(:,ij,ji,2) 750 751 ENDIF 726 727 END DO 752 728 753 729 END DO loop_p … … 763 739 !----------------------------------------------------------------------- 764 740 765 CALL obs_mpp_sum_integer ( ivar1t0, ivar1tmpp ) 766 CALL obs_mpp_sum_integer ( ivar2t0, ivar2tmpp ) 741 DO jvar = 1, kvars 742 CALL obs_mpp_sum_integer ( ivart0(jvar), ivartmpp(jvar) ) 743 END DO 767 744 CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) 768 745 769 CALL obs_mpp_sum_integers( itypvar1, itypvar1mpp, ntyp1770 + 1 ) 770 CALL obs_mpp_sum_integers( itypvar2, itypvar2mpp, ntyp1770 + 1 ) 746 DO jvar = 1, kvars 747 CALL obs_mpp_sum_integers( itypvar(:,jvar), itypvarmpp(:,jvar), ntyp1770 + 1 ) 748 END DO 771 749 772 750 !----------------------------------------------------------------------- … … 778 756 WRITE(numout,'(1X,A)') '------------' 779 757 WRITE(numout,*) 780 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(1) ) 781 WRITE(numout,'(1X,A)') '------------------------' 782 DO ji = 0, ntyp1770 783 IF ( itypvar1mpp(ji+1) > 0 ) THEN 784 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 785 & cwmonam1770(ji)(1:52),' = ', & 786 & itypvar1mpp(ji+1) 787 ENDIF 758 DO jvar = 1, kvars 759 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(jvar) ) 760 WRITE(numout,'(1X,A)') '------------------------' 761 DO ji = 0, ntyp1770 762 IF ( itypvarmpp(ji+1,jvar) > 0 ) THEN 763 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 764 & cwmonam1770(ji)(1:52),' = ', & 765 & itypvarmpp(ji+1,jvar) 766 ENDIF 767 END DO 768 WRITE(numout,'(1X,A)') & 769 & '---------------------------------------------------------------' 770 WRITE(numout,'(1X,A55,I8)') & 771 & 'Total profile data for variable '//TRIM( profdata%cvars(jvar) )// & 772 & ' = ', ivartmpp(jvar) 773 WRITE(numout,'(1X,A)') & 774 & '---------------------------------------------------------------' 775 WRITE(numout,*) 788 776 END DO 789 WRITE(numout,'(1X,A)') & 790 & '---------------------------------------------------------------' 791 WRITE(numout,'(1X,A55,I8)') & 792 & 'Total profile data for variable '//TRIM( profdata%cvars(1) )// & 793 & ' = ', ivar1tmpp 794 WRITE(numout,'(1X,A)') & 795 & '---------------------------------------------------------------' 796 WRITE(numout,*) 797 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(2) ) 798 WRITE(numout,'(1X,A)') '------------------------' 799 DO ji = 0, ntyp1770 800 IF ( itypvar2mpp(ji+1) > 0 ) THEN 801 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 802 & cwmonam1770(ji)(1:52),' = ', & 803 & itypvar2mpp(ji+1) 804 ENDIF 777 ENDIF 778 779 IF (ldsatt) THEN 780 profdata%nvprot(:) = ip3dt 781 profdata%nvprotmpp(:) = ip3dtmpp 782 ELSE 783 DO jvar = 1, kvars 784 profdata%nvprot(jvar) = ivart(jvar) 785 profdata%nvprotmpp(jvar) = ivartmpp(jvar) 805 786 END DO 806 WRITE(numout,'(1X,A)') &807 & '---------------------------------------------------------------'808 WRITE(numout,'(1X,A55,I8)') &809 & 'Total profile data for variable '//TRIM( profdata%cvars(2) )// &810 & ' = ', ivar2tmpp811 WRITE(numout,'(1X,A)') &812 & '---------------------------------------------------------------'813 WRITE(numout,*)814 ENDIF815 816 IF (ldsatt) THEN817 profdata%nvprot(1) = ip3dt818 profdata%nvprot(2) = ip3dt819 profdata%nvprotmpp(1) = ip3dtmpp820 profdata%nvprotmpp(2) = ip3dtmpp821 ELSE822 profdata%nvprot(1) = ivar1t823 profdata%nvprot(2) = ivar2t824 profdata%nvprotmpp(1) = ivar1tmpp825 profdata%nvprotmpp(2) = ivar2tmpp826 787 ENDIF 827 788 profdata%nprof = iprof … … 830 791 ! Model level search 831 792 !----------------------------------------------------------------------- 832 IF ( ldvar1 ) THEN 833 CALL obs_level_search( jpk, gdept_1d, & 834 & profdata%nvprot(1), profdata%var(1)%vdep, & 835 & profdata%var(1)%mvk ) 836 ENDIF 837 IF ( ldvar2 ) THEN 838 CALL obs_level_search( jpk, gdept_1d, & 839 & profdata%nvprot(2), profdata%var(2)%vdep, & 840 & profdata%var(2)%mvk ) 841 ENDIF 793 DO jvar = 1, kvars 794 IF ( ldvar(jvar) ) THEN 795 CALL obs_level_search( jpk, gdept_1d, & 796 & profdata%nvprot(jvar), profdata%var(jvar)%vdep, & 797 & profdata%var(jvar)%mvk ) 798 ENDIF 799 END DO 842 800 843 801 !----------------------------------------------------------------------- … … 852 810 ! Deallocate temporary data 853 811 !----------------------------------------------------------------------- 854 DEALLOCATE( ifileidx, iprofidx, zdat, clvars )812 DEALLOCATE( ifileidx, iprofidx, zdat, clvarsin ) 855 813 856 814 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_read_surf.F90
r13226 r14062 40 40 SUBROUTINE obs_rea_surf( surfdata, knumfiles, cdfilenames, & 41 41 & kvars, kextr, kstp, ddobsini, ddobsend, & 42 & ldignmis, ldmod, ldnightav )42 & ldignmis, ldmod, ldnightav, cdvars ) 43 43 !!--------------------------------------------------------------------- 44 44 !! … … 73 73 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 74 74 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 75 CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 75 76 76 77 !! * Local declarations 77 78 CHARACTER(LEN=11), PARAMETER :: cpname='obs_rea_surf' 78 79 CHARACTER(len=8) :: clrefdate 79 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 80 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin 80 81 INTEGER :: ji 81 82 INTEGER :: jj … … 178 179 & ldgrid = .TRUE. ) 179 180 181 IF ( inpfiles(jj)%nvar /= kvars ) THEN 182 CALL ctl_stop( 'Feedback format error: ', & 183 & ' unexpected number of vars in feedback file' ) 184 ENDIF 185 180 186 IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 181 187 CALL ctl_stop( 'Model not in input data' ) … … 184 190 185 191 IF ( jj == 1 ) THEN 186 ALLOCATE( clvars ( inpfiles(jj)%nvar ) )192 ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 187 193 DO ji = 1, inpfiles(jj)%nvar 188 clvars(ji) = inpfiles(jj)%cname(ji) 194 clvarsin(ji) = inpfiles(jj)%cname(ji) 195 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 196 CALL ctl_stop( 'Feedback file variables do not match', & 197 & ' expected variable names for this type' ) 198 ENDIF 189 199 END DO 190 200 ELSE 191 201 DO ji = 1, inpfiles(jj)%nvar 192 IF ( inpfiles(jj)%cname(ji) /= clvars (ji) ) THEN202 IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 193 203 CALL ctl_stop( 'Feedback file variables not consistent', & 194 204 & ' with previous files for this type' ) … … 347 357 iobs = 0 348 358 349 surfdata%cvars(:) = clvars (:)359 surfdata%cvars(:) = clvarsin(:) 350 360 351 361 ityp (:) = 0 … … 480 490 ! Deallocate temporary data 481 491 !----------------------------------------------------------------------- 482 DEALLOCATE( ifileidx, isurfidx, zdat, clvars )492 DEALLOCATE( ifileidx, isurfidx, zdat, clvarsin ) 483 493 484 494 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/OBS/obs_write.F90
r12933 r14062 86 86 CHARACTER(LEN=40) :: clfname 87 87 CHARACTER(LEN=10) :: clfiletype 88 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 89 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 90 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 88 91 CHARACTER(LEN=12) :: clfmt ! writing format 89 92 INTEGER :: idg ! number of digits … … 115 118 ! Find maximum level 116 119 ilevel = 0 117 DO jvar = 1, 2120 DO jvar = 1, profdata%nvar 118 121 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 119 122 END DO … … 180 183 181 184 END SELECT 185 186 IF ( ( TRIM(profdata%cvars(1)) /= 'POTM' ) .AND. & 187 & ( TRIM(profdata%cvars(1)) /= 'UVEL' ) ) THEN 188 CALL alloc_obfbdata( fbdata, 1, profdata%nprof, ilevel, & 189 & 1 + iadd, iext, .TRUE. ) 190 fbdata%cname(1) = profdata%cvars(1) 191 fbdata%coblong(1) = cllongname 192 fbdata%cobunit(1) = clunits 193 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(cllongname) 194 fbdata%caddunit(1,1) = clunits 195 fbdata%cgrid(:) = clgrid 196 DO je = 1, iext 197 fbdata%cextname(je) = pext%cdname(je) 198 fbdata%cextlong(je) = pext%cdlong(je,1) 199 fbdata%cextunit(je) = pext%cdunit(je,1) 200 END DO 201 DO ja = 1, iadd 202 fbdata%caddname(1+ja) = padd%cdname(ja) 203 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 204 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 205 END DO 206 ENDIF 182 207 183 208 fbdata%caddname(1) = 'Hx' … … 234 259 & krefdate = 19500101 ) 235 260 ! Reform the profiles arrays for output 236 DO jvar = 1, 2261 DO jvar = 1, profdata%nvar 237 262 DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 238 263 ik = profdata%var(jvar)%nvlidx(jk) … … 329 354 CHARACTER(LEN=40) :: clfname ! netCDF filename 330 355 CHARACTER(LEN=10) :: clfiletype 356 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 357 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 358 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 331 359 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 332 360 CHARACTER(LEN=12) :: clfmt ! writing format … … 354 382 SELECT CASE ( TRIM(surfdata%cvars(1)) ) 355 383 CASE('SLA') 384 385 ! SLA needs special treatment because of MDT, so is all done here 386 ! Other variables are done more generically 387 ! No climatology for SLA, MDT is our best estimate of that and is already output. 356 388 357 389 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & … … 384 416 CASE('SST') 385 417 418 clfiletype = 'sstfb' 419 cllongname = 'Sea surface temperature' 420 clunits = 'Degree centigrade' 421 clgrid = 'T' 422 423 CASE('ICECONC') 424 425 clfiletype = 'sicfb' 426 cllongname = 'Sea ice concentration' 427 clunits = 'Fraction' 428 clgrid = 'T' 429 430 CASE('SSS') 431 432 clfiletype = 'sssfb' 433 cllongname = 'Sea surface salinity' 434 clunits = 'psu' 435 clgrid = 'T' 436 437 CASE DEFAULT 438 439 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 440 441 END SELECT 442 443 ! SLA needs special treatment because of MDT, so is done above 444 ! Remaining variables treated more generically 445 446 IF ( TRIM(surfdata%cvars(1)) /= 'SLA' ) THEN 447 386 448 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 387 449 & 1 + iadd, iext, .TRUE. ) 388 450 389 clfiletype = 'sstfb'390 451 fbdata%cname(1) = surfdata%cvars(1) 391 fbdata%coblong(1) = 'Sea surface temperature'392 fbdata%cobunit(1) = 'Degree centigrade'452 fbdata%coblong(1) = cllongname 453 fbdata%cobunit(1) = clunits 393 454 DO je = 1, iext 394 455 fbdata%cextname(je) = pext%cdname(je) 395 456 fbdata%cextlong(je) = pext%cdlong(je,1) 396 457 fbdata%cextunit(je) = pext%cdunit(je,1) 397 END DO 398 fbdata%caddlong(1,1) = 'Model interpolated SST' 399 fbdata%caddunit(1,1) = 'Degree centigrade' 400 fbdata%cgrid(1) = 'T' 458 END DO 459 IF ( TRIM(surfdata%cvars(1)) == 'ICECONC' ) THEN 460 fbdata%caddlong(1,1) = 'Model interpolated ICE' 461 ELSE 462 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(surfdata%cvars(1)) 463 ENDIF 464 fbdata%caddunit(1,1) = clunits 465 fbdata%cgrid(1) = clgrid 401 466 DO ja = 1, iadd 402 467 fbdata%caddname(1+ja) = padd%cdname(ja) … … 404 469 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 405 470 END DO 406 407 CASE('ICECONC') 408 409 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 410 & 1 + iadd, iext, .TRUE. ) 411 412 clfiletype = 'sicfb' 413 fbdata%cname(1) = surfdata%cvars(1) 414 fbdata%coblong(1) = 'Sea ice' 415 fbdata%cobunit(1) = 'Fraction' 416 DO je = 1, iext 417 fbdata%cextname(je) = pext%cdname(je) 418 fbdata%cextlong(je) = pext%cdlong(je,1) 419 fbdata%cextunit(je) = pext%cdunit(je,1) 420 END DO 421 fbdata%caddlong(1,1) = 'Model interpolated ICE' 422 fbdata%caddunit(1,1) = 'Fraction' 423 fbdata%cgrid(1) = 'T' 424 DO ja = 1, iadd 425 fbdata%caddname(1+ja) = padd%cdname(ja) 426 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 427 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 428 END DO 429 430 CASE('SSS') 431 432 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 433 & 1 + iadd, iext, .TRUE. ) 434 435 clfiletype = 'sssfb' 436 fbdata%cname(1) = surfdata%cvars(1) 437 fbdata%coblong(1) = 'Sea surface salinity' 438 fbdata%cobunit(1) = 'psu' 439 DO je = 1, iext 440 fbdata%cextname(je) = pext%cdname(je) 441 fbdata%cextlong(je) = pext%cdlong(je,1) 442 fbdata%cextunit(je) = pext%cdunit(je,1) 443 END DO 444 fbdata%caddlong(1,1) = 'Model interpolated SSS' 445 fbdata%caddunit(1,1) = 'psu' 446 fbdata%cgrid(1) = 'T' 447 DO ja = 1, iadd 448 fbdata%caddname(1+ja) = padd%cdname(ja) 449 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 450 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 451 END DO 452 453 CASE DEFAULT 454 455 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 456 457 END SELECT 471 ENDIF 458 472 459 473 fbdata%caddname(1) = 'Hx' -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/SBC/sbcapr.F90
r14037 r14062 148 148 ! ! ---------------------------------------- ! 149 149 ! !* Restart: read in restart file 150 IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0) THEN150 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN 151 151 IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb read in the restart file' 152 152 CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb ) ! before inv. barometer ssh -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/SBC/sbcice_cice.F90
r13295 r14062 12 12 USE oce ! ocean dynamics and tracers 13 13 USE dom_oce ! ocean space and time domain 14 # if !defined key_qco15 USE dom vvl14 # if defined key_qco 15 USE domqco ! Variable volume 16 16 # else 17 USE dom qco17 USE domvvl ! Variable volume 18 18 # endif 19 19 USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi … … 238 238 !!gm especially here it is assumed zstar coordinate, but it can be ztilde.... 239 239 #if defined key_qco 240 IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm , Kaa) ! interpolation scale factor, depth and water column240 IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column 241 241 #else 242 242 IF( .NOT.ln_linssh ) THEN -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/SBC/sbcmod.F90
r14044 r14062 523 523 IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! 524 524 ! ! ---------------------------------------- ! 525 IF( ln_rstart .AND. & !* Restart: read in restart file 526 & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN 527 IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields red in the restart file' 528 CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b ) ! before i-stress (U-point) 529 CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b ) ! before j-stress (V-point) 530 CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b ) ! before non solar heat flux (T-point) 531 ! The 3D heat content due to qsr forcing is treated in traqsr 532 ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b ) ! before solar heat flux (T-point) 533 CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b ) ! before freshwater flux (T-point) 525 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN !* Restart: read in restart file 526 IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields read in the restart file' 527 CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b ) ! i-stress 528 CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b ) ! j-stress 529 CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b ) ! non solar heat flux 530 CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b ) ! freshwater flux 531 ! NB: The 3D heat content due to qsr forcing (qsr_hc_b) is treated in traqsr 534 532 ! To ensure restart capability with 3.3x/3.4 restart files !! to be removed in v3.6 535 533 IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN … … 566 564 ! ! ---------------------------------------- ! 567 565 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 568 CALL iom_put( "empmr" , emp 569 CALL iom_put( "empbmr" , emp_b 570 CALL iom_put( "saltflx", sfx )! downward salt flux (includes virtual salt flux beneath ice in linear free surface case)571 CALL iom_put( "fmmflx" , fmmflx )! Freezing-melting water flux572 CALL iom_put( "qt" , qns + qsr )! total heat flux573 CALL iom_put( "qns" , qns )! solar heat flux574 CALL iom_put( "qsr" , qsr )! solar heat flux566 CALL iom_put( "empmr" , emp - rnf ) ! upward water flux 567 CALL iom_put( "empbmr" , emp_b - rnf ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 568 CALL iom_put( "saltflx", sfx ) ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case) 569 CALL iom_put( "fmmflx" , fmmflx ) ! Freezing-melting water flux 570 CALL iom_put( "qt" , qns + qsr ) ! total heat flux 571 CALL iom_put( "qns" , qns ) ! solar heat flux 572 CALL iom_put( "qsr" , qsr ) ! solar heat flux 575 573 IF( nn_ice > 0 .OR. ll_opa ) CALL iom_put( "ice_cover", fr_i ) ! ice fraction 576 CALL iom_put( "taum" , taum )! wind stress module577 CALL iom_put( "wspd" , wndm )! wind speed module over free ocean or leads in presence of sea-ice578 CALL iom_put( "qrp" , qrp )! heat flux damping579 CALL iom_put( "erp" , erp )! freshwater flux damping574 CALL iom_put( "taum" , taum ) ! wind stress module 575 CALL iom_put( "wspd" , wndm ) ! wind speed module over free ocean or leads in presence of sea-ice 576 CALL iom_put( "qrp" , qrp ) ! heat flux damping 577 CALL iom_put( "erp" , erp ) ! freshwater flux damping 580 578 ENDIF 581 579 ! 582 580 IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) 583 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask )584 CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask )585 CALL prt_ctl(tab2d_1=(sfx-rnf) , clinfo1=' sfx-rnf - : ', mask1=tmask )586 CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask )587 CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask )588 CALL prt_ctl(tab3d_1=tmask , clinfo1=' tmask - : ', mask1=tmask, kdim=jpk )581 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask ) 582 CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask ) 583 CALL prt_ctl(tab2d_1=(sfx-rnf) , clinfo1=' sfx-rnf - : ', mask1=tmask ) 584 CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask ) 585 CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask ) 586 CALL prt_ctl(tab3d_1=tmask , clinfo1=' tmask - : ', mask1=tmask, kdim=jpk ) 589 587 CALL prt_ctl(tab3d_1=ts(:,:,:,jp_tem,Kmm), clinfo1=' sst - : ', mask1=tmask, kdim=1 ) 590 588 CALL prt_ctl(tab3d_1=ts(:,:,:,jp_sal,Kmm), clinfo1=' sss - : ', mask1=tmask, kdim=1 ) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/SBC/sbcrnf.F90
r14044 r14062 157 157 IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! 158 158 ! ! ---------------------------------------- ! 159 IF( ln_rstart .AND. & !* Restart: read in restart file 160 & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN 159 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN !* Restart: read in restart file 161 160 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields red in the restart file', lrxios 162 CALL iom_get( numror, jpdom_auto, 'rnf_b' , rnf_b )! before runoff161 CALL iom_get( numror, jpdom_auto, 'rnf_b' , rnf_b ) ! before runoff 163 162 CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) ) ! before heat content of runoff 164 163 CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) ) ! before salinity content of runoff 165 ELSE 164 ELSE !* no restart: set from nit000 values 166 165 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' 167 166 rnf_b (:,: ) = rnf (:,: ) … … 176 175 & 'at it= ', kt,' date= ', ndastp 177 176 IF(lwp) WRITE(numout,*) '~~~~' 178 CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf)177 CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf ) 179 178 CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem) ) 180 179 CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/traatf.F90
r14037 r14062 117 117 IF( l_trdtra ) THEN 118 118 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 119 ztrdt(:,:, jpk) = 0._wp120 ztrds(:,:, jpk) = 0._wp119 ztrdt(:,:,:) = 0._wp 120 ztrds(:,:,:) = 0._wp 121 121 IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend 122 122 CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_zdfp, ztrdt ) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/traatf_qco.F90
r14037 r14062 1 MODULE traatf qco1 MODULE traatf_qco 2 2 !!====================================================================== 3 !! *** MODULE traatf qco ***3 !! *** MODULE traatf_qco *** 4 4 !! Ocean active tracers: Asselin time filtering for temperature and salinity 5 5 !!====================================================================== … … 45 45 USE prtctl ! Print control 46 46 USE timing ! Timing 47 #if defined key_agrif48 USE agrif_oce_interp49 #endif50 47 51 48 IMPLICIT NONE … … 149 146 ENDIF 150 147 ! 151 CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1. , pts(:,:,:,jp_sal,Kmm) , 'T', 1.)152 148 CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp ) 149 ! 153 150 ENDIF 154 151 ! … … 370 367 371 368 !!====================================================================== 372 END MODULE traatf qco369 END MODULE traatf_qco -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/tramle.F90
r14037 r14062 20 20 USE lib_mpp ! MPP library 21 21 USE lbclnk ! lateral boundary condition / mpp link 22 23 ! where OSMOSIS_OBL is used with integrated FK 24 USE zdf_oce, ONLY : ln_zdfosm 25 USE zdfosm, ONLY : ln_osm_mle, hmle, dbdx_mle, dbdy_mle, mld_prof 22 26 23 27 IMPLICIT NONE … … 99 103 !!---------------------------------------------------------------------- 100 104 ! 101 ! !== MLD used for MLE ==! 102 ! ! compute from the 10m density to deal with the diurnal cycle 103 DO_2D( 1, 1, 1, 1 ) 104 inml_mle(ji,jj) = mbkt(ji,jj) + 1 ! init. to number of ocean w-level (T-level + 1) 105 END_2D 106 IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m 107 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 (10m) 108 IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle ) inml_mle(ji,jj) = jk ! Mixed layer 105 ! 106 IF(ln_osm_mle.and.ln_zdfosm) THEN 107 ikmax = MIN( MAXVAL( mld_prof(:,:) ), jpkm1 ) ! max level of the computation 108 ! 109 ! 110 SELECT CASE( nn_mld_uv ) ! MLD at u- & v-pts 111 CASE ( 0 ) != min of the 2 neighbour MLDs 112 DO_2D( 1, 0, 1, 0 ) 113 zhu(ji,jj) = MIN( hmle(ji+1,jj), hmle(ji,jj) ) 114 zhv(ji,jj) = MIN( hmle(ji,jj+1), hmle(ji,jj) ) 115 END_2D 116 CASE ( 1 ) != average of the 2 neighbour MLDs 117 DO_2D( 1, 0, 1, 0 ) 118 zhu(ji,jj) = MAX( hmle(ji+1,jj), hmle(ji,jj) ) 119 zhv(ji,jj) = MAX( hmle(ji,jj+1), hmle(ji,jj) ) 120 END_2D 121 CASE ( 2 ) != max of the 2 neighbour MLDs 122 DO_2D( 1, 0, 1, 0 ) 123 zhu(ji,jj) = MAX( hmle(ji+1,jj), hmle(ji,jj) ) 124 zhv(ji,jj) = MAX( hmle(ji,jj+1), hmle(ji,jj) ) 125 END_2D 126 END SELECT 127 IF( nn_mle == 0 ) THEN ! Fox-Kemper et al. 2010 formulation 128 DO_2D( 1, 0, 1, 0 ) 129 zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj) * e2u(ji,jj) & 130 & * dbdx_mle(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) & 131 & / ( MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) ) ) 132 ! 133 zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj) * e1v(ji,jj) & 134 & * dbdy_mle(ji,jj) * MIN( 111.e3_wp , e2v(ji,jj) ) & 135 & / ( MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) ) ) 136 END_2D 137 ! 138 ELSEIF( nn_mle == 1 ) THEN ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) 139 DO_2D( 1, 0, 1, 0 ) 140 zpsim_u(ji,jj) = rc_f * zhu(ji,jj) * zhu(ji,jj) * e2u(ji,jj) & 141 & * dbdx_mle(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) 142 ! 143 zpsim_v(ji,jj) = rc_f * zhv(ji,jj) * zhv(ji,jj) * e1v(ji,jj) & 144 & * dbdy_mle(ji,jj) * MIN( 111.e3_wp , e2v(ji,jj) ) 145 END_2D 146 ENDIF 147 148 ELSE !do not use osn_mle 149 ! !== MLD used for MLE ==! 150 ! ! compute from the 10m density to deal with the diurnal cycle 151 DO_2D( 1, 1, 1, 1 ) 152 inml_mle(ji,jj) = mbkt(ji,jj) + 1 ! init. to number of ocean w-level (T-level + 1) 153 END_2D 154 IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m 155 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 (10m) 156 IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle ) inml_mle(ji,jj) = jk ! Mixed layer 157 END_3D 158 ENDIF 159 ikmax = MIN( MAXVAL( inml_mle(:,:) ), jpkm1 ) ! max level of the computation 160 ! 161 ! 162 zmld(:,:) = 0._wp !== Horizontal shape of the MLE ==! 163 zbm (:,:) = 0._wp 164 zn2 (:,:) = 0._wp 165 DO_3D( 1, 1, 1, 1, 1, ikmax ) ! MLD and mean buoyancy and N2 over the mixed layer 166 zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1 ) ) ! zc being 0 outside the ML t-points 167 zmld(ji,jj) = zmld(ji,jj) + zc 168 zbm (ji,jj) = zbm (ji,jj) + zc * (rho0 - rhop(ji,jj,jk) ) * r1_rho0 169 zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp 109 170 END_3D 110 ENDIF 111 ikmax = MIN( MAXVAL( inml_mle(:,:) ), jpkm1 ) ! max level of the computation 112 ! 113 ! 114 zmld(:,:) = 0._wp !== Horizontal shape of the MLE ==! 115 zbm (:,:) = 0._wp 116 zn2 (:,:) = 0._wp 117 DO_3D( 1, 1, 1, 1, 1, ikmax ) ! MLD and mean buoyancy and N2 over the mixed layer 118 zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1 ) ) ! zc being 0 outside the ML t-points 119 zmld(ji,jj) = zmld(ji,jj) + zc 120 zbm (ji,jj) = zbm (ji,jj) + zc * (rho0 - rhop(ji,jj,jk) ) * r1_rho0 121 zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp 122 END_3D 123 124 SELECT CASE( nn_mld_uv ) ! MLD at u- & v-pts 125 CASE ( 0 ) != min of the 2 neighbour MLDs 126 DO_2D( 1, 0, 1, 0 ) 127 zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) 128 zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) 171 172 SELECT CASE( nn_mld_uv ) ! MLD at u- & v-pts 173 CASE ( 0 ) != min of the 2 neighbour MLDs 174 DO_2D( 1, 0, 1, 0 ) 175 zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) 176 zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) 177 END_2D 178 CASE ( 1 ) != average of the 2 neighbour MLDs 179 DO_2D( 1, 0, 1, 0 ) 180 zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp 181 zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp 182 END_2D 183 CASE ( 2 ) != max of the 2 neighbour MLDs 184 DO_2D( 1, 0, 1, 0 ) 185 zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) 186 zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) 187 END_2D 188 END SELECT 189 ! ! convert density into buoyancy 190 DO_2D( 1, 1, 1, 1 ) 191 zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), zmld(ji,jj) ) 129 192 END_2D 130 CASE ( 1 ) != average of the 2 neighbour MLDs 131 DO_2D( 1, 0, 1, 0 ) 132 zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp 133 zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp 134 END_2D 135 CASE ( 2 ) != max of the 2 neighbour MLDs 136 DO_2D( 1, 0, 1, 0 ) 137 zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) 138 zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) 139 END_2D 140 END SELECT 141 ! ! convert density into buoyancy 142 DO_2D( 1, 1, 1, 1 ) 143 zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), zmld(ji,jj) ) 144 END_2D 145 ! 146 ! 147 ! !== Magnitude of the MLE stream function ==! 148 ! 149 ! di[bm] Ds 150 ! Psi = Ce H^2 ---------------- e2u mu(z) where fu Lf = MAX( fu*rn_fl , (Db H)^1/2 ) 151 ! e1u Lf fu and the e2u for the "transport" 152 ! (not *e3u as divided by e3u at the end) 153 ! 154 IF( nn_mle == 0 ) THEN ! Fox-Kemper et al. 2010 formulation 155 DO_2D( 1, 0, 1, 0 ) 156 zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) & 157 & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) & 158 & / ( MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) ) ) 193 ! 194 ! 195 ! !== Magnitude of the MLE stream function ==! 196 ! 197 ! di[bm] Ds 198 ! Psi = Ce H^2 ---------------- e2u mu(z) where fu Lf = MAX( fu*rn_fl , (Db H)^1/2 ) 199 ! e1u Lf fu and the e2u for the "transport" 200 ! (not *e3u as divided by e3u at the end) 201 ! 202 IF( nn_mle == 0 ) THEN ! Fox-Kemper et al. 2010 formulation 203 DO_2D( 1, 0, 1, 0 ) 204 zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) & 205 & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) & 206 & / ( MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) ) ) 159 207 ! 160 zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj) * e1_e2v(ji,jj) &161 & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) &162 & / ( MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) ) )163 END_2D164 !165 ELSEIF( nn_mle == 1 ) THEN ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat)166 DO_2D( 1, 0, 1, 0 )167 zpsim_u(ji,jj) = rc_f * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) &168 & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )208 zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj) * e1_e2v(ji,jj) & 209 & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) & 210 & / ( MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) ) ) 211 END_2D 212 ! 213 ELSEIF( nn_mle == 1 ) THEN ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) 214 DO_2D( 1, 0, 1, 0 ) 215 zpsim_u(ji,jj) = rc_f * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) & 216 & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) 169 217 ! 170 zpsim_v(ji,jj) = rc_f * zhv(ji,jj) * zhv(ji,jj) * e1_e2v(ji,jj) & 171 & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) 172 END_2D 173 ENDIF 174 ! 175 IF( nn_conv == 1 ) THEN ! No MLE in case of convection 176 DO_2D( 1, 0, 1, 0 ) 177 IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp ) zpsim_u(ji,jj) = 0._wp 178 IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp ) zpsim_v(ji,jj) = 0._wp 179 END_2D 180 ENDIF 181 ! 182 ! !== structure function value at uw- and vw-points ==! 183 DO_2D( 1, 0, 1, 0 ) 184 zhu(ji,jj) = 1._wp / zhu(ji,jj) ! hu --> 1/hu 185 zhv(ji,jj) = 1._wp / zhv(ji,jj) 186 END_2D 187 ! 188 zpsi_uw(:,:,:) = 0._wp 189 zpsi_vw(:,:,:) = 0._wp 190 ! 218 zpsim_v(ji,jj) = rc_f * zhv(ji,jj) * zhv(ji,jj) * e1_e2v(ji,jj) & 219 & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) 220 END_2D 221 ENDIF 222 ! 223 IF( nn_conv == 1 ) THEN ! No MLE in case of convection 224 DO_2D( 1, 0, 1, 0 ) 225 IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp ) zpsim_u(ji,jj) = 0._wp 226 IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp ) zpsim_v(ji,jj) = 0._wp 227 END_2D 228 ENDIF 229 ! 230 ENDIF ! end of ln_osm_mle conditional 231 ! !== structure function value at uw- and vw-points ==! 232 DO_2D( 1, 0, 1, 0 ) 233 zhu(ji,jj) = 1._wp / MAX(zhu(ji,jj), rsmall) ! hu --> 1/hu 234 zhv(ji,jj) = 1._wp / MAX(zhv(ji,jj), rsmall) 235 END_2D 236 ! 237 zpsi_uw(:,:,:) = 0._wp 238 zpsi_vw(:,:,:) = 0._wp 239 ! 191 240 DO_3D( 1, 0, 1, 0, 2, ikmax ) ! start from 2 : surface value = 0 192 241 zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj) … … 220 269 ENDIF 221 270 ! 222 DO_2D( 0, 0, 0, 0 ) 223 zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj) ! Lf = N H / f 224 END_2D 271 IF (ln_osm_mle.and.ln_zdfosm) THEN 272 DO_2D( 0, 0, 0, 0 ) 273 zLf_NH(ji,jj) = SQRT( rb_c * hmle(ji,jj) ) * r1_ft(ji,jj) ! Lf = N H / f 274 END_2D 275 ELSE 276 DO_2D( 0, 0, 0, 0 ) 277 zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj) ! Lf = N H / f 278 END_2D 279 ENDIF 225 280 ! 226 281 ! divide by cross distance to give streamfunction with dimensions m^2/s … … 239 294 ! 240 295 END SUBROUTINE tra_mle_trp 241 242 296 243 297 SUBROUTINE tra_mle_init … … 301 355 IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 302 356 z1_t2 = 1._wp / ( rn_time * rn_time ) 303 DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls) ! "coriolis+ time^-1" at u- & v-points357 DO_2D( 0, 1, 0, 1 ) ! "coriolis+ time^-1" at u- & v-points 304 358 zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 305 359 zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp … … 307 361 rfv(ji,jj) = SQRT( zfv * zfv + z1_t2 ) 308 362 END_2D 309 IF (nn_hls.EQ.1)CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp )363 CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 310 364 ! 311 365 ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/traqsr.F90
r14037 r14062 144 144 145 145 IF( kt == nit000 ) THEN !== 1st time step ==! 146 IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 .AND..NOT.l_1st_euler ) THEN ! read in restart146 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN ! read in restart 147 147 z1_2 = 0.5_wp 148 148 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile … … 150 150 CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b ) ! before heat content trend due to Qsr flux 151 151 ENDIF 152 ELSE ! No restart or restart not found: Euler forward time stepping152 ELSE ! No restart or Euler forward at 1st time step 153 153 z1_2 = 1._wp 154 154 DO_3D( isj, iej, isi, iei, 1, jpk ) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/trasbc.F90
r14037 r14062 72 72 !! - send trends to trdtra module for further diagnostics(l_trdtra=T) 73 73 !!---------------------------------------------------------------------- 74 INTEGER, INTENT(in ) :: kt ! ocean time-step index75 INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices76 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation74 INTEGER, INTENT(in ) :: kt ! ocean time-step index 75 INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices 76 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer Eq. 77 77 ! 78 78 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 117 117 ! !== Set before sbc tracer content fields ==! 118 118 IF( kt == nit000 ) THEN !* 1st time-step 119 IF( ln_rstart .AND. & ! Restart: read in restart file 120 & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 119 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN ! Restart: read in restart file 121 120 zfact = 0.5_wp 122 121 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile … … 126 125 CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) ) ! before salt content sbc trend 127 126 ENDIF 128 ELSE ! No restart or restart not found: Euler forward time stepping127 ELSE ! No restart or restart not found: Euler forward time stepping 129 128 zfact = 1._wp 130 129 DO_2D( isj, iej, isi, iei ) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRD/trd_oce.F90
r10068 r14062 33 33 # endif 34 34 ! !!!* Active tracers trends indexes 35 INTEGER, PUBLIC, PARAMETER :: jptot_tra = 2 0!: Total trend nb: change it when adding/removing one indice below35 INTEGER, PUBLIC, PARAMETER :: jptot_tra = 21 !: Total trend nb: change it when adding/removing one indice below 36 36 ! =============== ! 37 37 INTEGER, PUBLIC, PARAMETER :: jptra_xad = 1 !: x- horizontal advection … … 46 46 INTEGER, PUBLIC, PARAMETER :: jptra_bbc = 10 !: Bottom Boundary Condition (geoth. heating) 47 47 INTEGER, PUBLIC, PARAMETER :: jptra_bbl = 11 !: Bottom Boundary Layer (diffusive and/or advective) 48 INTEGER, PUBLIC, PARAMETER :: jptra_osm = 21 !: Non-local terms from OSMOSIS OBL model 48 49 INTEGER, PUBLIC, PARAMETER :: jptra_npc = 12 !: non-penetrative convection treatment 49 50 INTEGER, PUBLIC, PARAMETER :: jptra_dmp = 13 !: internal restoring (damping) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/USR/usrdef_istate.F90
r14037 r14062 7 7 !! User defined : set the initial state of a user configuration 8 8 !!====================================================================== 9 !! History : 4.0 ! 2016-03 (S. Flavoni) Original code 9 !! History : 4.0 ! 2016-03 (S. Flavoni) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 22 23 PRIVATE 23 24 24 PUBLIC usr_def_istate ! called in istate.F90 25 PUBLIC usr_def_istate ! called in istate.F90 26 PUBLIC usr_def_istate_ssh ! called by domqco.F90 25 27 26 28 !! * Substitutions … … 33 35 CONTAINS 34 36 35 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)37 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 36 38 !!---------------------------------------------------------------------- 37 39 !! *** ROUTINE usr_def_istate *** … … 48 50 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 49 51 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 50 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height51 52 ! 52 53 INTEGER :: ji, jj, jk ! dummy loop indices … … 59 60 pu (:,:,:) = 0._wp ! ocean at rest 60 61 pv (:,:,:) = 0._wp 61 pssh(:,:) = 0._wp62 62 ! 63 63 DO_3D( 1, 1, 1, 1, 1, jpk ) ! horizontally uniform T & S profiles … … 80 80 END SUBROUTINE usr_def_istate 81 81 82 83 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 84 !!---------------------------------------------------------------------- 85 !! *** ROUTINE usr_def_istate_ssh *** 86 !! 87 !! ** Purpose : Initialization of ssh 88 !! 89 !! ** Method : Set ssh as null, ptmask is required for test cases 90 !!---------------------------------------------------------------------- 91 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 92 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 93 !!---------------------------------------------------------------------- 94 ! 95 IF(lwp) WRITE(numout,*) 96 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : GYRE configuration, analytical definition of initial state' 97 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~ Ocean at rest, ssh is zero' 98 ! 99 ! Sea level: 100 pssh(:,:) = 0._wp 101 ! 102 END SUBROUTINE usr_def_istate_ssh 103 82 104 !!====================================================================== 83 105 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ZDF/zdfddm.F90
r14037 r14062 31 31 !! * Substitutions 32 32 # include "do_loop_substitute.h90" 33 # include "domzgr_substitute.h90" 33 34 !!---------------------------------------------------------------------- 34 35 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ZDF/zdfosm.F90
r14037 r14062 25 25 !! (12) Replace zwstrl with zvstr in calculation of eddy viscosity. 26 26 !! 27/09/2017 (13) Calculate Stokes drift and Stokes penetration depth from wave information 27 !! (14) B ouyancy flux due to entrainment changed to include contribution from shear turbulence (for testing commented out).27 !! (14) Buoyancy flux due to entrainment changed to include contribution from shear turbulence. 28 28 !! 28/09/2017 (15) Calculation of Stokes drift moved into separate do-loops to allow for different options for the determining the Stokes drift to be added. 29 29 !! (16) Calculation of Stokes drift from windspeed for PM spectrum (for testing, commented out) 30 30 !! (17) Modification to Langmuir velocity scale to include effects due to the Stokes penetration depth (for testing, commented out) 31 !! ??/??/2018 (18) Revision to code structure, selected using key_osmldpth1. Inline code moved into subroutines. Changes to physics made, 32 !! (a) Pycnocline temperature and salinity profies changed for unstable layers 33 !! (b) The stable OSBL depth parametrization changed. 34 !! 16/05/2019 (19) Fox-Kemper parametrization of restratification through mixed layer eddies added to revised code. 35 !! 23/05/19 (20) Old code where key_osmldpth1` is *not* set removed, together with the key key_osmldpth1 31 36 !!---------------------------------------------------------------------- 32 37 … … 40 45 !! trc_osm : compute and add to the passive tracer trend the non-local flux (TBD) 41 46 !! dyn_osm : compute and add to u & v trensd the non-local flux 47 !! 48 !! Subroutines in revised code. 42 49 !!---------------------------------------------------------------------- 43 50 USE oce ! ocean dynamics and active tracers … … 69 76 PUBLIC tra_osm ! routine called by step.F90 70 77 PUBLIC trc_osm ! routine called by trcstp.F90 71 PUBLIC dyn_osm ! routine called by 'step.F90' 78 PUBLIC dyn_osm ! routine called by step.F90 79 80 PUBLIC ln_osm_mle ! logical needed by tra_mle_init in tramle.F90 72 81 73 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamu !: non-local u-momentum flux … … 77 86 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: etmean !: averaging operator for avt 78 87 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbl !: boundary layer depth 79 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbli !: intial boundary layer depth for stable blayer 88 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dh ! depth of pycnocline 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hml ! ML depth 80 90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dstokes !: penetration depth of the Stokes drift. 91 92 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ft ! inverse of the modified Coriolis parameter at t-pts 93 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmle ! Depth of layer affexted by mixed layer eddies in Fox-Kemper parametrization 94 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdx_mle ! zonal buoyancy gradient in ML 95 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdy_mle ! meridional buoyancy gradient in ML 96 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mld_prof ! level of base of MLE layer. 81 97 82 98 ! !!** Namelist namzdf_osm ** 83 99 LOGICAL :: ln_use_osm_la ! Use namelist rn_osm_la 100 101 LOGICAL :: ln_osm_mle !: flag to activate the Mixed Layer Eddy (MLE) parameterisation 102 84 103 REAL(wp) :: rn_osm_la ! Turbulent Langmuir number 85 104 REAL(wp) :: rn_osm_dstokes ! Depth scale of Stokes drift 105 REAL(wp) :: rn_zdfosm_adjust_sd = 1.0 ! factor to reduce Stokes drift by 106 REAL(wp) :: rn_osm_hblfrac = 0.1! for nn_osm_wave = 3/4 specify fraction in top of hbl 107 LOGICAL :: ln_zdfosm_ice_shelter ! flag to activate ice sheltering 86 108 REAL(wp) :: rn_osm_hbl0 = 10._wp ! Initial value of hbl for 1D runs 87 109 INTEGER :: nn_ave ! = 0/1 flag for horizontal average on avt 88 110 INTEGER :: nn_osm_wave = 0 ! = 0/1/2 flag for getting stokes drift from La# / PM wind-waves/Inputs into sbcwave 111 INTEGER :: nn_osm_SD_reduce ! = 0/1/2 flag for getting effective stokes drift from surface value 89 112 LOGICAL :: ln_dia_osm ! Use namelist rn_osm_la 90 113 … … 96 119 REAL(wp) :: rn_difconv = 1._wp ! diffusivity when unstable below BL (m2/s) 97 120 121 ! OSMOSIS mixed layer eddy parametrization constants 122 INTEGER :: nn_osm_mle ! = 0/1 flag for horizontal average on avt 123 REAL(wp) :: rn_osm_mle_ce ! MLE coefficient 124 ! ! parameters used in nn_osm_mle = 0 case 125 REAL(wp) :: rn_osm_mle_lf ! typical scale of mixed layer front 126 REAL(wp) :: rn_osm_mle_time ! time scale for mixing momentum across the mixed layer 127 ! ! parameters used in nn_osm_mle = 1 case 128 REAL(wp) :: rn_osm_mle_lat ! reference latitude for a 5 km scale of ML front 129 LOGICAL :: ln_osm_hmle_limit ! If true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld 130 REAL(wp) :: rn_osm_hmle_limit ! If ln_osm_hmle_limit true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld 131 REAL(wp) :: rn_osm_mle_rho_c ! Density criterion for definition of MLD used by FK 132 REAL(wp) :: r5_21 = 5.e0 / 21.e0 ! factor used in mle streamfunction computation 133 REAL(wp) :: rb_c ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld 134 REAL(wp) :: rc_f ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_osm_mle=1 case 135 REAL(wp) :: rn_osm_mle_thresh ! Threshold buoyancy for deepening of MLE layer below OSBL base. 136 REAL(wp) :: rn_osm_bl_thresh ! Threshold buoyancy for deepening of OSBL base. 137 REAL(wp) :: rn_osm_mle_tau ! Adjustment timescale for MLE. 138 139 98 140 ! !!! ** General constants ** 99 REAL(wp) :: epsln = 1.0e-20_wp ! a small positive number 141 REAL(wp) :: epsln = 1.0e-20_wp ! a small positive number to ensure no div by zero 142 REAL(wp) :: depth_tol = 1.0e-6_wp ! a small-ish positive number to give a hbl slightly shallower than gdepw 100 143 REAL(wp) :: pthird = 1._wp/3._wp ! 1/3 101 144 REAL(wp) :: p2third = 2._wp/3._wp ! 2/3 … … 118 161 !! *** FUNCTION zdf_osm_alloc *** 119 162 !!---------------------------------------------------------------------- 120 ALLOCATE( ghamu(jpi,jpj,jpk), ghamv(jpi,jpj,jpk), ghamt(jpi,jpj,jpk), ghams(jpi,jpj,jpk), & 121 & hbl(jpi,jpj) , hbli(jpi,jpj) , dstokes(jpi, jpj) , & 122 & etmean(jpi,jpj,jpk), STAT= zdf_osm_alloc ) 163 ALLOCATE( ghamu(jpi,jpj,jpk), ghamv(jpi,jpj,jpk), ghamt(jpi,jpj,jpk),ghams(jpi,jpj,jpk), & 164 & hbl(jpi,jpj), dh(jpi,jpj), hml(jpi,jpj), dstokes(jpi, jpj), & 165 & etmean(jpi,jpj,jpk), STAT= zdf_osm_alloc ) 166 167 ALLOCATE( hmle(jpi,jpj), r1_ft(jpi,jpj), dbdx_mle(jpi,jpj), dbdy_mle(jpi,jpj), & 168 & mld_prof(jpi,jpj), STAT= zdf_osm_alloc ) 169 170 CALL mpp_sum ( 'zdfosm', zdf_osm_alloc ) 123 171 IF( zdf_osm_alloc /= 0 ) CALL ctl_warn('zdf_osm_alloc: failed to allocate zdf_osm arrays') 124 CALL mpp_sum ( 'zdfosm', zdf_osm_alloc ) 172 125 173 END FUNCTION zdf_osm_alloc 126 174 … … 166 214 !! 167 215 INTEGER :: ji, jj, jk ! dummy loop indices 216 217 INTEGER :: jl ! dummy loop indices 218 168 219 INTEGER :: ikbot, jkmax, jkm1, jkp2 ! 169 220 … … 196 247 REAL(wp), DIMENSION(jpi,jpj) :: zwbav ! Buoyancy flux - bl average 197 248 REAL(wp), DIMENSION(jpi,jpj) :: zwb_ent ! Buoyancy entrainment flux 249 REAL(wp), DIMENSION(jpi,jpj) :: zwb_min 250 251 252 REAL(wp), DIMENSION(jpi,jpj) :: zwb_fk_b ! MLE buoyancy flux averaged over OSBL 253 REAL(wp), DIMENSION(jpi,jpj) :: zwb_fk ! max MLE buoyancy flux 254 REAL(wp), DIMENSION(jpi,jpj) :: zdiff_mle ! extra MLE vertical diff 255 REAL(wp), DIMENSION(jpi,jpj) :: zvel_mle ! velocity scale for dhdt with stable ML and FK 256 198 257 REAL(wp), DIMENSION(jpi,jpj) :: zustke ! Surface Stokes drift 199 258 REAL(wp), DIMENSION(jpi,jpj) :: zla ! Trubulent Langmuir number … … 201 260 REAL(wp), DIMENSION(jpi,jpj) :: zsin_wind ! Sin angle of surface stress 202 261 REAL(wp), DIMENSION(jpi,jpj) :: zhol ! Stability parameter for boundary layer 203 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: lconv ! unstable/stable bl 262 LOGICAL, DIMENSION(jpi,jpj) :: lconv ! unstable/stable bl 263 LOGICAL, DIMENSION(jpi,jpj) :: lshear ! Shear layers 264 LOGICAL, DIMENSION(jpi,jpj) :: lpyc ! OSBL pycnocline present 265 LOGICAL, DIMENSION(jpi,jpj) :: lflux ! surface flux extends below OSBL into MLE layer. 266 LOGICAL, DIMENSION(jpi,jpj) :: lmle ! MLE layer increases in hickness. 204 267 205 268 ! mixed-layer variables … … 207 270 INTEGER, DIMENSION(jpi,jpj) :: ibld ! level of boundary layer base 208 271 INTEGER, DIMENSION(jpi,jpj) :: imld ! level of mixed-layer depth (pycnocline top) 272 INTEGER, DIMENSION(jpi,jpj) :: jp_ext, jp_ext_mle ! offset for external level 273 INTEGER, DIMENSION(jpi, jpj) :: j_ddh ! Type of shear layer 209 274 210 275 REAL(wp) :: ztgrad,zsgrad,zbgrad ! Temporary variables used to calculate pycnocline gradients … … 213 278 REAL(wp), DIMENSION(jpi,jpj) :: zhbl ! bl depth - grid 214 279 REAL(wp), DIMENSION(jpi,jpj) :: zhml ! ml depth - grid 280 281 REAL(wp), DIMENSION(jpi,jpj) :: zhmle ! MLE depth - grid 282 REAL(wp), DIMENSION(jpi,jpj) :: zmld ! ML depth on grid 283 215 284 REAL(wp), DIMENSION(jpi,jpj) :: zdh ! pycnocline depth - grid 216 285 REAL(wp), DIMENSION(jpi,jpj) :: zdhdt ! BL depth tendency 217 REAL(wp), DIMENSION(jpi,jpj) :: zt_bl,zs_bl,zu_bl,zv_bl,zrh_bl ! averages over the depth of the blayer 218 REAL(wp), DIMENSION(jpi,jpj) :: zt_ml,zs_ml,zu_ml,zv_ml,zrh_ml ! averages over the depth of the mixed layer 219 REAL(wp), DIMENSION(jpi,jpj) :: zdt_bl,zds_bl,zdu_bl,zdv_bl,zdrh_bl,zdb_bl ! difference between blayer average and parameter at base of blayer 220 REAL(wp), DIMENSION(jpi,jpj) :: zdt_ml,zds_ml,zdu_ml,zdv_ml,zdrh_ml,zdb_ml ! difference between mixed layer average and parameter at base of blayer 221 REAL(wp), DIMENSION(jpi,jpj) :: zwth_ent,zws_ent ! heat and salinity fluxes at the top of the pycnocline 222 REAL(wp), DIMENSION(jpi,jpj) :: zuw_bse,zvw_bse ! momentum fluxes at the top of the pycnocline 286 REAL(wp), DIMENSION(jpi,jpj) :: zddhdt ! correction to dhdt due to internal structure. 287 REAL(wp), DIMENSION(jpi,jpj) :: zdtdz_bl_ext,zdsdz_bl_ext,zdbdz_bl_ext ! external temperature/salinity and buoyancy gradients 288 REAL(wp), DIMENSION(jpi,jpj) :: zdtdz_mle_ext,zdsdz_mle_ext,zdbdz_mle_ext ! external temperature/salinity and buoyancy gradients 289 REAL(wp), DIMENSION(jpi,jpj) :: zdtdx, zdtdy, zdsdx, zdsdy ! horizontal gradients for Fox-Kemper parametrization. 290 291 REAL(wp), DIMENSION(jpi,jpj) :: zt_bl,zs_bl,zu_bl,zv_bl,zb_bl ! averages over the depth of the blayer 292 REAL(wp), DIMENSION(jpi,jpj) :: zt_ml,zs_ml,zu_ml,zv_ml,zb_ml ! averages over the depth of the mixed layer 293 REAL(wp), DIMENSION(jpi,jpj) :: zt_mle,zs_mle,zu_mle,zv_mle,zb_mle ! averages over the depth of the MLE layer 294 REAL(wp), DIMENSION(jpi,jpj) :: zdt_bl,zds_bl,zdu_bl,zdv_bl,zdb_bl ! difference between blayer average and parameter at base of blayer 295 REAL(wp), DIMENSION(jpi,jpj) :: zdt_ml,zds_ml,zdu_ml,zdv_ml,zdb_ml ! difference between mixed layer average and parameter at base of blayer 296 REAL(wp), DIMENSION(jpi,jpj) :: zdt_mle,zds_mle,zdu_mle,zdv_mle,zdb_mle ! difference between MLE layer average and parameter at base of blayer 297 ! REAL(wp), DIMENSION(jpi,jpj) :: zwth_ent,zws_ent ! heat and salinity fluxes at the top of the pycnocline 298 REAL(wp) :: zwth_ent,zws_ent ! heat and salinity fluxes at the top of the pycnocline 299 REAL(wp) :: zuw_bse,zvw_bse ! momentum fluxes at the top of the pycnocline 223 300 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdtdz_pyc ! parametrized gradient of temperature in pycnocline 224 301 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdsdz_pyc ! parametrised gradient of salinity in pycnocline … … 226 303 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdudz_pyc ! u-shear across the pycnocline 227 304 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdvdz_pyc ! v-shear across the pycnocline 228 305 REAL(wp), DIMENSION(jpi,jpj) :: zdbds_mle ! Magnitude of horizontal buoyancy gradient. 229 306 ! Flux-gradient relationship variables 307 REAL(wp), DIMENSION(jpi, jpj) :: zshear, zri_i ! Shear production and interfacial richardon number. 230 308 231 309 REAL(wp) :: zl_c,zl_l,zl_eps ! Used to calculate turbulence length scale. 232 310 233 REAL(wp) , DIMENSION(jpi,jpj) :: zdifml_sc,zvisml_sc,zdifpyc_sc,zvispyc_sc,zbeta_d_sc,zbeta_v_sc ! Scales for eddy diffusivity/viscosity311 REAL(wp) :: za_cubic, zb_cubic, zc_cubic, zd_cubic ! coefficients in cubic polynomial specifying diffusivity in pycnocline. 234 312 REAL(wp), DIMENSION(jpi,jpj) :: zsc_wth_1,zsc_ws_1 ! Temporary scales used to calculate scalar non-gradient terms. 313 REAL(wp), DIMENSION(jpi,jpj) :: zsc_wth_pyc, zsc_ws_pyc ! Scales for pycnocline transport term/ 235 314 REAL(wp), DIMENSION(jpi,jpj) :: zsc_uw_1,zsc_uw_2,zsc_vw_1,zsc_vw_2 ! Temporary scales for non-gradient momentum flux terms. 236 315 REAL(wp), DIMENSION(jpi,jpj) :: zhbl_t ! holds boundary layer depth updated by full timestep … … 243 322 ! Temporary variables 244 323 INTEGER :: inhml 245 INTEGER :: i_lconv_alloc246 324 REAL(wp) :: znd,znd_d,zznd_ml,zznd_pyc,zznd_d ! temporary non-dimensional depths used in various routines 247 325 REAL(wp) :: ztemp, zari, zpert, zzdhdt, zdb ! temporary variables 248 326 REAL(wp) :: zthick, zz0, zz1 ! temporary variables 249 327 REAL(wp) :: zvel_max, zhbl_s ! temporary variables 250 REAL(wp) :: zfac 328 REAL(wp) :: zfac, ztmp ! temporary variable 251 329 REAL(wp) :: zus_x, zus_y ! temporary Stokes drift 252 330 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zviscos ! viscosity 253 331 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdiffut ! t-diffusivity 332 REAL(wp), DIMENSION(jpi,jpj) :: zalpha_pyc 333 REAL(wp), DIMENSION(jpi,jpj) :: ztau_sc_u ! dissipation timescale at baes of WML. 334 REAL(wp) :: zdelta_pyc, zwt_pyc_sc_1, zws_pyc_sc_1, zzeta_pyc 335 REAL(wp) :: zbuoy_pyc_sc, zomega, zvw_max 336 INTEGER :: ibld_ext=0 ! does not have to be zero for modified scheme 337 REAL(wp) :: zgamma_b_nd, zgamma_b, zdhoh, ztau 338 REAL(wp) :: zzeta_s = 0._wp 339 REAL(wp) :: zzeta_v = 0.46 340 REAL(wp) :: zabsstke 341 REAL(wp) :: zsqrtpi, z_two_thirds, zproportion, ztransp, zthickness 342 REAL(wp) :: z2k_times_thickness, zsqrt_depth, zexp_depth, zdstokes0, zf, zexperfc 254 343 255 344 ! For debugging … … 257 346 !!-------------------------------------------------------------------- 258 347 ! 259 ALLOCATE( lconv(jpi,jpj), STAT= i_lconv_alloc )260 IF( i_lconv_alloc /= 0 ) CALL ctl_warn('zdf_osm: failed to allocate lconv')261 262 348 ibld(:,:) = 0 ; imld(:,:) = 0 263 349 zrad0(:,:) = 0._wp ; zradh(:,:) = 0._wp ; zradav(:,:) = 0._wp ; zustar(:,:) = 0._wp … … 267 353 zustke(:,:) = 0._wp ; zla(:,:) = 0._wp ; zcos_wind(:,:) = 0._wp ; zsin_wind(:,:) = 0._wp 268 354 zhol(:,:) = 0._wp 269 lconv(:,:) = .FALSE. 355 lconv(:,:) = .FALSE.; lpyc(:,:) = .FALSE. ; lflux(:,:) = .FALSE. ; lmle(:,:) = .FALSE. 270 356 ! mixed layer 271 357 ! no initialization of zhbl or zhml (or zdh?) 272 358 zhbl(:,:) = 1._wp ; zhml(:,:) = 1._wp ; zdh(:,:) = 1._wp ; zdhdt(:,:) = 0._wp 273 zt_bl(:,:) = 0._wp ; zs_bl(:,:) = 0._wp ; zu_bl(:,:) = 0._wp ; zv_bl(:,:) = 0._wp 274 zrh_bl(:,:) = 0._wp ; zt_ml(:,:) = 0._wp ; zs_ml(:,:) = 0._wp ; zu_ml(:,:) = 0._wp 275 zv_ml(:,:) = 0._wp ; zrh_ml(:,:) = 0._wp ; zdt_bl(:,:) = 0._wp ; zds_bl(:,:) = 0._wp 276 zdu_bl(:,:) = 0._wp ; zdv_bl(:,:) = 0._wp ; zdrh_bl(:,:) = 0._wp ; zdb_bl(:,:) = 0._wp 359 zt_bl(:,:) = 0._wp ; zs_bl(:,:) = 0._wp ; zu_bl(:,:) = 0._wp 360 zv_bl(:,:) = 0._wp ; zb_bl(:,:) = 0._wp 361 zt_ml(:,:) = 0._wp ; zs_ml(:,:) = 0._wp ; zu_ml(:,:) = 0._wp 362 zt_mle(:,:) = 0._wp ; zs_mle(:,:) = 0._wp ; zu_mle(:,:) = 0._wp 363 zb_mle(:,:) = 0._wp 364 zv_ml(:,:) = 0._wp ; zdt_bl(:,:) = 0._wp ; zds_bl(:,:) = 0._wp 365 zdu_bl(:,:) = 0._wp ; zdv_bl(:,:) = 0._wp ; zdb_bl(:,:) = 0._wp 277 366 zdt_ml(:,:) = 0._wp ; zds_ml(:,:) = 0._wp ; zdu_ml(:,:) = 0._wp ; zdv_ml(:,:) = 0._wp 278 zdrh_ml(:,:) = 0._wp ; zdb_ml(:,:) = 0._wp ; zwth_ent(:,:) = 0._wp ; zws_ent(:,:) = 0._wp 279 zuw_bse(:,:) = 0._wp ; zvw_bse(:,:) = 0._wp 367 zdb_ml(:,:) = 0._wp 368 zdt_mle(:,:) = 0._wp ; zds_mle(:,:) = 0._wp ; zdu_mle(:,:) = 0._wp 369 zdv_mle(:,:) = 0._wp ; zdb_mle(:,:) = 0._wp 370 zwth_ent = 0._wp ; zws_ent = 0._wp 280 371 ! 281 372 zdtdz_pyc(:,:,:) = 0._wp ; zdsdz_pyc(:,:,:) = 0._wp ; zdbdz_pyc(:,:,:) = 0._wp 282 373 zdudz_pyc(:,:,:) = 0._wp ; zdvdz_pyc(:,:,:) = 0._wp 283 374 ! 375 zdtdz_bl_ext(:,:) = 0._wp ; zdsdz_bl_ext(:,:) = 0._wp ; zdbdz_bl_ext(:,:) = 0._wp 376 377 IF ( ln_osm_mle ) THEN ! only initialise arrays if needed 378 zdtdx(:,:) = 0._wp ; zdtdy(:,:) = 0._wp ; zdsdx(:,:) = 0._wp 379 zdsdy(:,:) = 0._wp ; dbdx_mle(:,:) = 0._wp ; dbdy_mle(:,:) = 0._wp 380 zwb_fk(:,:) = 0._wp ; zvel_mle(:,:) = 0._wp; zdiff_mle(:,:) = 0._wp 381 zhmle(:,:) = 0._wp ; zmld(:,:) = 0._wp 382 ENDIF 383 zwb_fk_b(:,:) = 0._wp ! must be initialised even with ln_osm_mle=F as used in zdf_osm_calculate_dhdt 384 284 385 ! Flux-Gradient arrays. 285 zdifml_sc(:,:) = 0._wp ; zvisml_sc(:,:) = 0._wp ; zdifpyc_sc(:,:) = 0._wp286 zvispyc_sc(:,:) = 0._wp ; zbeta_d_sc(:,:) = 0._wp ; zbeta_v_sc(:,:) = 0._wp287 386 zsc_wth_1(:,:) = 0._wp ; zsc_ws_1(:,:) = 0._wp ; zsc_uw_1(:,:) = 0._wp 288 387 zsc_uw_2(:,:) = 0._wp ; zsc_vw_1(:,:) = 0._wp ; zsc_vw_2(:,:) = 0._wp … … 292 391 ghams(:,:,:) = 0._wp ; ghamu(:,:,:) = 0._wp ; ghamv(:,:,:) = 0._wp 293 392 393 zddhdt(:,:) = 0._wp 294 394 ! hbl = MAX(hbl,epsln) 295 395 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 326 426 zwbav(ji,jj) = grav * zthermal * zwthav(ji,jj) - grav * zbeta * zwsav(ji,jj) 327 427 ! Surface upward velocity fluxes 328 zuw0(ji,jj) = - utau(ji,jj) * r1_rho0 * tmask(ji,jj,1)329 zvw0(ji,jj) = - vtau(ji,jj) * r1_rho0 * tmask(ji,jj,1)428 zuw0(ji,jj) = - 0.5 * (utau(ji-1,jj) + utau(ji,jj)) * r1_rho0 * tmask(ji,jj,1) 429 zvw0(ji,jj) = - 0.5 * (vtau(ji,jj-1) + vtau(ji,jj)) * r1_rho0 * tmask(ji,jj,1) 330 430 ! Friction velocity (zustar), at T-point : LMD94 eq. 2 331 431 zustar(ji,jj) = MAX( SQRT( SQRT( zuw0(ji,jj) * zuw0(ji,jj) + zvw0(ji,jj) * zvw0(ji,jj) ) ), 1.0e-8 ) … … 340 440 zus_x = zcos_wind(ji,jj) * zustar(ji,jj) / 0.3**2 341 441 zus_y = zsin_wind(ji,jj) * zustar(ji,jj) / 0.3**2 442 ! Linearly 342 443 zustke(ji,jj) = MAX ( SQRT( zus_x*zus_x + zus_y*zus_y), 1.0e-8 ) 343 ! dstokes(ji,jj) set to constant value rn_osm_dstokes from namelist in zdf_osm_init444 dstokes(ji,jj) = rn_osm_dstokes 344 445 END_2D 345 446 ! Assume Pierson-Moskovitz wind-wave spectrum … … 347 448 DO_2D( 0, 0, 0, 0 ) 348 449 ! Use wind speed wndm included in sbc_oce module 349 zustke(ji,jj) = MAX ( 0.016 * wndm(ji,jj), 1.0e-8 )350 dstokes(ji,jj) = 0.12 * wndm(ji,jj)**2 / grav450 zustke(ji,jj) = MAX ( 0.016 * wndm(ji,jj), 1.0e-8 ) 451 dstokes(ji,jj) = MAX ( 0.12 * wndm(ji,jj)**2 / grav, 5.e-1) 351 452 END_2D 352 453 ! Use ECMWF wave fields as output from SBCWAVE 353 454 CASE(2) 354 455 zfac = 2.0_wp * rpi / 16.0_wp 456 355 457 DO_2D( 0, 0, 0, 0 ) 356 ! The Langmur number from the ECMWF model appears to give La<0.3 for wind-driven seas. 357 ! The coefficient 0.8 gives La=0.3 in this situation. 358 ! It could represent the effects of the spread of wave directions 359 ! around the mean wind. The effect of this adjustment needs to be tested. 360 zustke(ji,jj) = MAX ( 1.0 * ( zcos_wind(ji,jj) * ut0sd(ji,jj ) + zsin_wind(ji,jj) * vt0sd(ji,jj) ), & 361 & zustar(ji,jj) / ( 0.45 * 0.45 ) ) 362 dstokes(ji,jj) = MAX(zfac * hsw(ji,jj)*hsw(ji,jj) / ( MAX(zustke(ji,jj)*wmp(ji,jj), 1.0e-7 ) ), 5.0e-1) !rn_osm_dstokes ! 458 IF (hsw(ji,jj) > 1.e-4) THEN 459 ! Use wave fields 460 zabsstke = SQRT(ut0sd(ji,jj)**2 + vt0sd(ji,jj)**2) 461 zustke(ji,jj) = MAX ( ( zcos_wind(ji,jj) * ut0sd(ji,jj) + zsin_wind(ji,jj) * vt0sd(ji,jj) ), 1.0e-8) 462 dstokes(ji,jj) = MAX (zfac * hsw(ji,jj)*hsw(ji,jj) / ( MAX(zabsstke * wmp(ji,jj), 1.0e-7 ) ), 5.0e-1) 463 ELSE 464 ! Assume masking issue (e.g. ice in ECMWF reanalysis but not in model run) 465 ! .. so default to Pierson-Moskowitz 466 zustke(ji,jj) = MAX ( 0.016 * wndm(ji,jj), 1.0e-8 ) 467 dstokes(ji,jj) = MAX ( 0.12 * wndm(ji,jj)**2 / grav, 5.e-1) 468 END IF 469 END_2D 470 END SELECT 471 472 IF (ln_zdfosm_ice_shelter) THEN 473 ! Reduce both Stokes drift and its depth scale by ocean fraction to represent sheltering by ice 474 DO_2D( 0, 0, 0, 0 ) 475 zustke(ji,jj) = zustke(ji,jj) * (1.0_wp - fr_i(ji,jj)) 476 dstokes(ji,jj) = dstokes(ji,jj) * (1.0_wp - fr_i(ji,jj)) 477 END_2D 478 END IF 479 480 SELECT CASE (nn_osm_SD_reduce) 481 ! Reduce surface Stokes drift by a constant factor or following Breivik (2016) + van Roekel (2012) or Grant (2020). 482 CASE(0) 483 ! The Langmur number from the ECMWF model (or from PM) appears to give La<0.3 for wind-driven seas. 484 ! The coefficient rn_zdfosm_adjust_sd = 0.8 gives La=0.3 in this situation. 485 ! It could represent the effects of the spread of wave directions 486 ! around the mean wind. The effect of this adjustment needs to be tested. 487 IF(nn_osm_wave > 0) THEN 488 zustke(2:jpim1,2:jpjm1) = rn_zdfosm_adjust_sd * zustke(2:jpim1,2:jpjm1) 489 END IF 490 CASE(1) 491 ! van Roekel (2012): consider average SD over top 10% of boundary layer 492 ! assumes approximate depth profile of SD from Breivik (2016) 493 zsqrtpi = SQRT(rpi) 494 z_two_thirds = 2.0_wp / 3.0_wp 495 496 DO_2D( 0, 0, 0, 0 ) 497 zthickness = rn_osm_hblfrac*hbl(ji,jj) 498 z2k_times_thickness = zthickness * 2.0_wp / MAX( ABS( 5.97_wp * dstokes(ji,jj) ), 0.0000001_wp ) 499 zsqrt_depth = SQRT(z2k_times_thickness) 500 zexp_depth = EXP(-z2k_times_thickness) 501 zustke(ji,jj) = zustke(ji,jj) * (1.0_wp - zexp_depth & 502 & - z_two_thirds * ( zsqrtpi*zsqrt_depth*z2k_times_thickness * ERFC(zsqrt_depth) & 503 & + 1.0_wp - (1.0_wp + z2k_times_thickness)*zexp_depth ) ) / z2k_times_thickness 504 505 END_2D 506 CASE(2) 507 ! Grant (2020): Match to exponential with same SD and d/dz(Sd) at depth 10% of boundary layer 508 ! assumes approximate depth profile of SD from Breivik (2016) 509 zsqrtpi = SQRT(rpi) 510 511 DO_2D( 0, 0, 0, 0 ) 512 zthickness = rn_osm_hblfrac*hbl(ji,jj) 513 z2k_times_thickness = zthickness * 2.0_wp / MAX( ABS( 5.97_wp * dstokes(ji,jj) ), 0.0000001_wp ) 514 515 IF(z2k_times_thickness < 50._wp) THEN 516 zsqrt_depth = SQRT(z2k_times_thickness) 517 zexperfc = zsqrtpi * zsqrt_depth * ERFC(zsqrt_depth) * EXP(z2k_times_thickness) 518 ELSE 519 ! asymptotic expansion of sqrt(pi)*zsqrt_depth*EXP(z2k_times_thickness)*ERFC(zsqrt_depth) for large z2k_times_thickness 520 ! See Abramowitz and Stegun, Eq. 7.1.23 521 ! zexperfc = 1._wp - (1/2)/(z2k_times_thickness) + (3/4)/(z2k_times_thickness**2) - (15/8)/(z2k_times_thickness**3) 522 zexperfc = ((- 1.875_wp/z2k_times_thickness + 0.75_wp)/z2k_times_thickness - 0.5_wp)/z2k_times_thickness + 1.0_wp 523 END IF 524 zf = z2k_times_thickness*(1.0_wp/zexperfc - 1.0_wp) 525 dstokes(ji,jj) = 5.97 * zf * dstokes(ji,jj) 526 zustke(ji,jj) = zustke(ji,jj) * EXP(z2k_times_thickness * ( 1.0_wp / (2. * zf) - 1.0_wp )) * ( 1.0_wp - zexperfc) 363 527 END_2D 364 528 END SELECT … … 369 533 ! Langmuir velocity scale (zwstrl), at T-point 370 534 zwstrl(ji,jj) = ( zustar(ji,jj) * zustar(ji,jj) * zustke(ji,jj) )**pthird 371 ! Modify zwstrl to allow for small and large values of dstokes/hbl. 372 ! Intended as a possible test. Doesn't affect LES results for entrainment, 373 ! but hasn't been shown to be correct as dstokes/h becomes large or small. 374 zwstrl(ji,jj) = zwstrl(ji,jj) * & 375 & (1.12 * ( 1.0 - ( 1.0 - EXP( -hbl(ji,jj) / dstokes(ji,jj) ) ) * dstokes(ji,jj) / hbl(ji,jj) ))**pthird * & 376 & ( 1.0 - EXP( -15.0 * dstokes(ji,jj) / hbl(ji,jj) )) 377 ! define La this way so effects of Stokes penetration depth on velocity scale are included 378 zla(ji,jj) = SQRT ( zustar(ji,jj) / zwstrl(ji,jj) )**3 535 zla(ji,jj) = MAX(MIN(SQRT ( zustar(ji,jj) / ( zwstrl(ji,jj) + epsln ) )**3, 4.0), 0.2) 536 IF(zla(ji,jj) > 0.45) dstokes(ji,jj) = MIN(dstokes(ji,jj), 0.5_wp*hbl(ji,jj)) 379 537 ! Velocity scale that tends to zustar for large Langmuir numbers 380 538 zvstr(ji,jj) = ( zwstrl(ji,jj)**3 + & … … 383 541 ! limit maximum value of Langmuir number as approximate treatment for shear turbulence. 384 542 ! Note zustke and zwstrl are not amended. 385 IF ( zla(ji,jj) >= 0.45 ) zla(ji,jj) = 0.45386 543 ! 387 544 ! get convective velocity (zwstrc), stabilty scale (zhol) and logical conection flag lconv … … 389 546 zwstrc(ji,jj) = ( 2.0 * zwbav(ji,jj) * 0.9 * hbl(ji,jj) )**pthird 390 547 zhol(ji,jj) = -0.9 * hbl(ji,jj) * 2.0 * zwbav(ji,jj) / (zvstr(ji,jj)**3 + epsln ) 391 lconv(ji,jj) = .TRUE. 392 ELSE 548 ELSE 393 549 zhol(ji,jj) = -hbl(ji,jj) * 2.0 * zwbav(ji,jj)/ (zvstr(ji,jj)**3 + epsln ) 394 lconv(ji,jj) = .FALSE.395 550 ENDIF 396 551 END_2D … … 399 554 ! Mixed-layer model - calculate averages over the boundary layer, and the change in the boundary layer depth 400 555 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 401 ! BL must be always 2 levels deep. 402 hbl(:,:) = MAX(hbl(:,:), gdepw(:,:,3,Kmm) ) 403 ibld(:,:) = 3 404 DO_3D( 0, 0, 0, 0, 4, jpkm1 ) 556 ! BL must be always 4 levels deep. 557 ! For calculation of lateral buoyancy gradients for FK in 558 ! zdf_osm_zmld_horizontal_gradients need halo values for ibld, so must 559 ! previously exist for hbl also. 560 561 ! agn 23/6/20: not clear all this is needed, as hbl checked after it is re-calculated anyway 562 ! ########################################################################## 563 hbl(:,:) = MAX(hbl(:,:), gdepw(:,:,4,Kmm) ) 564 ibld(:,:) = 4 565 DO_3D( 1, 1, 1, 1, 5, jpkm1 ) 405 566 IF ( hbl(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) THEN 406 567 ibld(ji,jj) = MIN(mbkt(ji,jj), jk) 407 568 ENDIF 408 569 END_3D 570 ! ########################################################################## 409 571 410 572 DO_2D( 0, 0, 0, 0 ) 411 zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 412 zbeta = rab_n(ji,jj,1,jp_sal) 413 zt = 0._wp 414 zs = 0._wp 415 zu = 0._wp 416 zv = 0._wp 417 ! average over depth of boundary layer 418 zthick=0._wp 419 DO jm = 2, ibld(ji,jj) 420 zthick=zthick+e3t(ji,jj,jm,Kmm) 421 zt = zt + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_tem,Kmm) 422 zs = zs + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_sal,Kmm) 423 zu = zu + e3t(ji,jj,jm,Kmm) & 424 & * ( uu(ji,jj,jm,Kbb) + uu(ji - 1,jj,jm,Kbb) ) & 425 & / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) 426 zv = zv + e3t(ji,jj,jm,Kmm) & 427 & * ( vv(ji,jj,jm,Kbb) + vv(ji,jj - 1,jm,Kbb) ) & 428 & / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) 429 END DO 430 zt_bl(ji,jj) = zt / zthick 431 zs_bl(ji,jj) = zs / zthick 432 zu_bl(ji,jj) = zu / zthick 433 zv_bl(ji,jj) = zv / zthick 434 zdt_bl(ji,jj) = zt_bl(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_tem,Kmm) 435 zds_bl(ji,jj) = zs_bl(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_sal,Kmm) 436 zdu_bl(ji,jj) = zu_bl(ji,jj) - ( uu(ji,jj,ibld(ji,jj),Kbb) + uu(ji-1,jj,ibld(ji,jj) ,Kbb) ) & 437 & / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) 438 zdv_bl(ji,jj) = zv_bl(ji,jj) - ( vv(ji,jj,ibld(ji,jj),Kbb) + vv(ji,jj-1,ibld(ji,jj) ,Kbb) ) & 439 & / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) 440 zdb_bl(ji,jj) = grav * zthermal * zdt_bl(ji,jj) - grav * zbeta * zds_bl(ji,jj) 441 IF ( lconv(ji,jj) ) THEN ! Convective 442 zwb_ent(ji,jj) = -( 2.0 * 0.2 * zwbav(ji,jj) & 443 & + 0.135 * zla(ji,jj) * zwstrl(ji,jj)**3/hbl(ji,jj) ) 444 445 zvel_max = - ( 1.0 + 1.0 * ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / hbl(ji,jj) ) & 446 & * zwb_ent(ji,jj) / ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 447 ! Entrainment including component due to shear turbulence. Modified Langmuir component, but gives same result for La=0.3 For testing uncomment. 448 ! zwb_ent(ji,jj) = -( 2.0 * 0.2 * zwbav(ji,jj) & 449 ! & + ( 0.15 * ( 1.0 - EXP( -0.5 * zla(ji,jj) ) ) + 0.03 / zla(ji,jj)**2 ) * zustar(ji,jj)**3/hbl(ji,jj) ) 450 451 ! zvel_max = - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / zhbl(ji,jj) ) * zwb_ent(ji,jj) / & 452 ! & ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 453 zzdhdt = - zwb_ent(ji,jj) / ( zvel_max + MAX(zdb_bl(ji,jj),0.0) ) 454 ELSE ! Stable 455 zzdhdt = 0.32 * ( hbli(ji,jj) / hbl(ji,jj) -1.0 ) * zwstrl(ji,jj)**3 / hbli(ji,jj) & 456 & + ( ( 0.32 / 3.0 ) * exp ( -2.5 * ( hbli(ji,jj) / hbl(ji,jj) - 1.0 ) ) & 457 & - ( 0.32 / 3.0 - 0.135 * zla(ji,jj) ) * exp ( -12.5 * ( hbli(ji,jj) / hbl(ji,jj) ) ) ) & 458 & * zwstrl(ji,jj)**3 / hbli(ji,jj) 459 zzdhdt = zzdhdt + zwbav(ji,jj) 460 IF ( zzdhdt < 0._wp ) THEN 461 ! For long timsteps factor in brackets slows the rapid collapse of the OSBL 462 zpert = 2.0 * ( 1.0 + 2.0 * zwstrl(ji,jj) * rn_Dt / hbl(ji,jj) ) * zwstrl(ji,jj)**2 / hbl(ji,jj) 463 ELSE 464 zpert = 2.0 * ( 1.0 + 2.0 * zwstrl(ji,jj) * rn_Dt / hbl(ji,jj) ) * zwstrl(ji,jj)**2 / hbl(ji,jj) & 465 & + MAX( zdb_bl(ji,jj), 0.0 ) 466 ENDIF 467 zzdhdt = 2.0 * zzdhdt / zpert 468 ENDIF 469 zdhdt(ji,jj) = zzdhdt 573 zhbl(ji,jj) = gdepw(ji,jj,ibld(ji,jj),Kmm) 574 imld(ji,jj) = MAX(3,ibld(ji,jj) - MAX( INT( dh(ji,jj) / e3t(ji, jj, ibld(ji,jj), Kmm )) , 1 )) 575 zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 576 zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 470 577 END_2D 471 472 ! Calculate averages over depth of boundary layer 473 imld = ibld ! use imld to hold previous blayer index 474 ibld(:,:) = 3 475 476 zhbl_t(:,:) = hbl(:,:) + (zdhdt(:,:) - ww(ji,jj,ibld(ji,jj)))* rn_Dt ! certainly need wb here, so subtract it 477 zhbl_t(:,:) = MIN(zhbl_t(:,:), ht(:,:)) 478 zdhdt(:,:) = MIN(zdhdt(:,:), (zhbl_t(:,:) - hbl(:,:))/rn_Dt + ww(ji,jj,ibld(ji,jj))) ! adjustment to represent limiting by ocean bottom 578 ! Averages over well-mixed and boundary layer 579 jp_ext(:,:) = 2 580 CALL zdf_osm_vertical_average(ibld, jp_ext, zt_bl, zs_bl, zb_bl, zu_bl, zv_bl, zdt_bl, zds_bl, zdb_bl, zdu_bl, zdv_bl) 581 ! jp_ext(:,:) = ibld(:,:) - imld(:,:) + 1 582 CALL zdf_osm_vertical_average(ibld, ibld-imld+1, zt_ml, zs_ml, zb_ml, zu_ml, zv_ml, zdt_ml, zds_ml, zdb_ml, zdu_ml, zdv_ml) 583 ! Velocity components in frame aligned with surface stress. 584 CALL zdf_osm_velocity_rotation( zcos_wind, zsin_wind, zu_ml, zv_ml, zdu_ml, zdv_ml ) 585 CALL zdf_osm_velocity_rotation( zcos_wind, zsin_wind, zu_bl, zv_bl, zdu_bl, zdv_bl ) 586 ! Determine the state of the OSBL, stable/unstable, shear/no shear 587 CALL zdf_osm_osbl_state( lconv, lshear, j_ddh, zwb_ent, zwb_min, zshear, zri_i ) 588 589 IF ( ln_osm_mle ) THEN 590 ! Fox-Kemper Scheme 591 mld_prof = 4 592 DO_3D( 0, 0, 0, 0, 5, jpkm1 ) 593 IF ( hmle(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) mld_prof(ji,jj) = MIN(mbkt(ji,jj), jk) 594 END_3D 595 jp_ext_mle(:,:) = 2 596 CALL zdf_osm_vertical_average(mld_prof, jp_ext_mle, zt_mle, zs_mle, zb_mle, zu_mle, zv_mle, zdt_mle, zds_mle, zdb_mle, zdu_mle, zdv_mle) 597 598 DO_2D( 0, 0, 0, 0 ) 599 zhmle(ji,jj) = gdepw(ji,jj,mld_prof(ji,jj),Kmm) 600 END_2D 601 602 !! External gradient 603 CALL zdf_osm_external_gradients( ibld+2, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext ) 604 CALL zdf_osm_zmld_horizontal_gradients( zmld, zdtdx, zdtdy, zdsdx, zdsdy, dbdx_mle, dbdy_mle, zdbds_mle ) 605 CALL zdf_osm_external_gradients( mld_prof, zdtdz_mle_ext, zdsdz_mle_ext, zdbdz_mle_ext ) 606 CALL zdf_osm_osbl_state_fk( lpyc, lflux, lmle, zwb_fk ) 607 CALL zdf_osm_mle_parameters( mld_prof, hmle, zhmle, zvel_mle, zdiff_mle ) 608 ELSE ! ln_osm_mle 609 ! FK not selected, Boundary Layer only. 610 lpyc(:,:) = .TRUE. 611 lflux(:,:) = .FALSE. 612 lmle(:,:) = .FALSE. 613 DO_2D( 0, 0, 0, 0 ) 614 IF ( lconv(ji,jj) .AND. zdb_bl(ji,jj) < rn_osm_bl_thresh ) lpyc(ji,jj) = .FALSE. 615 END_2D 616 ENDIF ! ln_osm_mle 617 618 ! Test if pycnocline well resolved 619 DO_2D( 0, 0, 0, 0 ) 620 IF (lconv(ji,jj) ) THEN 621 ztmp = 0.2 * zhbl(ji,jj) / e3w(ji,jj,ibld(ji,jj),Kmm) 622 IF ( ztmp > 6 ) THEN 623 ! pycnocline well resolved 624 jp_ext(ji,jj) = 1 625 ELSE 626 ! pycnocline poorly resolved 627 jp_ext(ji,jj) = 0 628 ENDIF 629 ELSE 630 ! Stable conditions 631 jp_ext(ji,jj) = 0 632 ENDIF 633 END_2D 634 635 CALL zdf_osm_vertical_average(ibld, jp_ext, zt_bl, zs_bl, zb_bl, zu_bl, zv_bl, zdt_bl, zds_bl, zdb_bl, zdu_bl, zdv_bl ) 636 ! jp_ext = ibld-imld+1 637 CALL zdf_osm_vertical_average(imld-1, ibld-imld+1, zt_ml, zs_ml, zb_ml, zu_ml, zv_ml, zdt_ml, zds_ml, zdb_ml, zdu_ml, zdv_ml) 638 ! Rate of change of hbl 639 CALL zdf_osm_calculate_dhdt( zdhdt, zddhdt ) 640 DO_2D( 0, 0, 0, 0 ) 641 zhbl_t(ji,jj) = hbl(ji,jj) + (zdhdt(ji,jj) - ww(ji,jj,ibld(ji,jj)))* rn_Dt ! certainly need ww here, so subtract it 642 ! adjustment to represent limiting by ocean bottom 643 IF ( zhbl_t(ji,jj) >= gdepw(ji, jj, mbkt(ji,jj) + 1, Kmm ) ) THEN 644 zhbl_t(ji,jj) = MIN(zhbl_t(ji,jj), gdepw(ji,jj, mbkt(ji,jj) + 1, Kmm) - depth_tol)! ht(:,:)) 645 lpyc(ji,jj) = .FALSE. 646 ENDIF 647 END_2D 648 649 imld(:,:) = ibld(:,:) ! use imld to hold previous blayer index 650 ibld(:,:) = 4 479 651 480 652 DO_3D( 0, 0, 0, 0, 4, jpkm1 ) 481 653 IF ( zhbl_t(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) THEN 482 ibld(ji,jj) = MIN(mbkt(ji,jj), jk)654 ibld(ji,jj) = jk 483 655 ENDIF 484 656 END_3D … … 487 659 ! Step through model levels taking account of buoyancy change to determine the effect on dhdt 488 660 ! 661 CALL zdf_osm_timestep_hbl( zdhdt ) 662 ! is external level in bounds? 663 664 CALL zdf_osm_vertical_average( ibld, jp_ext, zt_bl, zs_bl, zb_bl, zu_bl, zv_bl, zdt_bl, zds_bl, zdb_bl, zdu_bl, zdv_bl ) 665 ! 666 ! 667 ! Check to see if lpyc needs to be changed 668 669 CALL zdf_osm_pycnocline_thickness( dh, zdh ) 670 489 671 DO_2D( 0, 0, 0, 0 ) 490 IF ( ibld(ji,jj) - imld(ji,jj) > 1 ) THEN 672 IF ( zdb_bl(ji,jj) < rn_osm_bl_thresh .or. ibld(ji,jj) + jp_ext(ji,jj) >= mbkt(ji,jj) .or. ibld(ji,jj)-imld(ji,jj) == 1 ) lpyc(ji,jj) = .FALSE. 673 END_2D 674 675 dstokes(:,:) = MIN ( dstokes(:,:), hbl(:,:)/3. ) ! Limit delta for shallow boundary layers for calculating flux-gradient terms. 491 676 ! 492 ! If boundary layer changes by more than one level, need to check for stable layers between initial and final depths. 493 ! 494 zhbl_s = hbl(ji,jj) 495 jm = imld(ji,jj) 496 zthermal = rab_n(ji,jj,1,jp_tem) 497 zbeta = rab_n(ji,jj,1,jp_sal) 498 IF ( lconv(ji,jj) ) THEN 499 !unstable 500 zvel_max = - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / hbl(ji,jj) ) & 501 & * zwb_ent(ji,jj) / ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 502 503 DO jk = imld(ji,jj), ibld(ji,jj) 504 zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) ) & 505 & - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0 ) + zvel_max 506 507 zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_Dt / FLOAT(ibld(ji,jj)-imld(ji,jj) ), & 508 & e3w(ji,jj,jk,Kmm) ) 509 zhbl_s = MIN(zhbl_s, ht(ji,jj)) 510 511 IF ( zhbl_s >= gdepw(ji,jj,jm+1,Kmm) ) jm = jm + 1 512 END DO 513 hbl(ji,jj) = zhbl_s 514 ibld(ji,jj) = jm 515 hbli(ji,jj) = hbl(ji,jj) 516 ELSE 517 ! stable 518 DO jk = imld(ji,jj), ibld(ji,jj) 519 zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) ) & 520 & - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0 ) & 521 & + 2.0 * zwstrl(ji,jj)**2 / zhbl_s 522 523 zhbl_s = zhbl_s + ( & 524 & 0.32 * ( hbli(ji,jj) / zhbl_s -1.0 ) & 525 & * zwstrl(ji,jj)**3 / hbli(ji,jj) & 526 & + ( ( 0.32 / 3.0 ) * EXP( - 2.5 * ( hbli(ji,jj) / zhbl_s -1.0 ) ) & 527 & - ( 0.32 / 3.0 - 0.0485 ) * EXP( - 12.5 * ( hbli(ji,jj) / zhbl_s ) ) ) & 528 & * zwstrl(ji,jj)**3 / hbli(ji,jj) ) / zdb * e3w(ji,jj,jk,Kmm) / zdhdt(ji,jj) ! ALMG to investigate whether need to include ww here 529 530 zhbl_s = MIN(zhbl_s, ht(ji,jj)) 531 IF ( zhbl_s >= gdepw(ji,jj,jm,Kmm) ) jm = jm + 1 532 END DO 533 hbl(ji,jj) = MAX(zhbl_s, gdepw(ji,jj,3,Kmm) ) 534 ibld(ji,jj) = MAX(jm, 3 ) 535 IF ( hbl(ji,jj) > hbli(ji,jj) ) hbli(ji,jj) = hbl(ji,jj) 536 ENDIF ! IF ( lconv ) 537 ELSE 538 ! change zero or one model level. 539 hbl(ji,jj) = zhbl_t(ji,jj) 540 IF ( lconv(ji,jj) ) THEN 541 hbli(ji,jj) = hbl(ji,jj) 542 ELSE 543 hbl(ji,jj) = MAX(hbl(ji,jj), gdepw(ji,jj,3,Kmm) ) 544 IF ( hbl(ji,jj) > hbli(ji,jj) ) hbli(ji,jj) = hbl(ji,jj) 545 ENDIF 546 ENDIF 547 zhbl(ji,jj) = gdepw(ji,jj,ibld(ji,jj),Kmm) 548 END_2D 549 dstokes(:,:) = MIN ( dstokes(:,:), hbl(:,:)/3. ) ! Limit delta for shallow boundary layers for calculating flux-gradient terms. 550 551 ! Recalculate averages over boundary layer after depth updated 552 ! Consider later combining this into the loop above and looking for columns 553 ! where the index for base of the boundary layer have changed 554 DO_2D( 0, 0, 0, 0 ) 555 zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 556 zbeta = rab_n(ji,jj,1,jp_sal) 557 zt = 0._wp 558 zs = 0._wp 559 zu = 0._wp 560 zv = 0._wp 561 ! average over depth of boundary layer 562 zthick=0._wp 563 DO jm = 2, ibld(ji,jj) 564 zthick=zthick+e3t(ji,jj,jm,Kmm) 565 zt = zt + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_tem,Kmm) 566 zs = zs + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_sal,Kmm) 567 zu = zu + e3t(ji,jj,jm,Kmm) & 568 & * ( uu(ji,jj,jm,Kbb) + uu(ji - 1,jj,jm,Kbb) ) & 569 & / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) 570 zv = zv + e3t(ji,jj,jm,Kmm) & 571 & * ( vv(ji,jj,jm,Kbb) + vv(ji,jj - 1,jm,Kbb) ) & 572 & / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) 573 END DO 574 zt_bl(ji,jj) = zt / zthick 575 zs_bl(ji,jj) = zs / zthick 576 zu_bl(ji,jj) = zu / zthick 577 zv_bl(ji,jj) = zv / zthick 578 zdt_bl(ji,jj) = zt_bl(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_tem,Kmm) 579 zds_bl(ji,jj) = zs_bl(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_sal,Kmm) 580 zdu_bl(ji,jj) = zu_bl(ji,jj) - ( uu(ji,jj,ibld(ji,jj),Kbb) + uu(ji-1,jj,ibld(ji,jj) ,Kbb) ) & 581 & / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) 582 zdv_bl(ji,jj) = zv_bl(ji,jj) - ( vv(ji,jj,ibld(ji,jj),Kbb) + vv(ji,jj-1,ibld(ji,jj) ,Kbb) ) & 583 & / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) 584 zdb_bl(ji,jj) = grav * zthermal * zdt_bl(ji,jj) - grav * zbeta * zds_bl(ji,jj) 585 zhbl(ji,jj) = gdepw(ji,jj,ibld(ji,jj),Kmm) 586 IF ( lconv(ji,jj) ) THEN 587 IF ( zdb_bl(ji,jj) > 0._wp )THEN 588 IF ( ( zwstrc(ji,jj) / zvstr(ji,jj) )**3 <= 0.5 ) THEN ! near neutral stability 589 zari = 4.5 * ( zvstr(ji,jj)**2 ) & 590 & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 591 ELSE ! unstable 592 zari = 4.5 * ( zwstrc(ji,jj)**2 ) & 593 & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 594 ENDIF 595 IF ( zari > 0.2 ) THEN ! This test checks for weakly stratified pycnocline 596 zari = 0.2 597 zwb_ent(ji,jj) = 0._wp 598 ENDIF 599 inhml = MAX( INT( zari * zhbl(ji,jj) & 600 & / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 ) 601 imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) 602 zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 603 zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 604 ELSE ! IF (zdb_bl) 605 imld(ji,jj) = ibld(ji,jj) - 1 606 zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 607 zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 608 ENDIF 609 ELSE ! IF (lconv) 610 IF ( zdhdt(ji,jj) >= 0.0 ) THEN ! probably shouldn't include wm here 611 ! boundary layer deepening 612 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 613 ! pycnocline thickness set by stratification - use same relationship as for neutral conditions. 614 zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & 615 & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 , 0.2 ) 616 inhml = MAX( INT( zari * zhbl(ji,jj) & 617 & / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 ) 618 imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) 619 zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 620 zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 621 ELSE 622 imld(ji,jj) = ibld(ji,jj) - 1 623 zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 624 zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 625 ENDIF ! IF (zdb_bl > 0.0) 626 ELSE ! IF(dhdt >= 0) 627 ! boundary layer collapsing. 628 imld(ji,jj) = ibld(ji,jj) 629 zhml(ji,jj) = zhbl(ji,jj) 630 zdh(ji,jj) = 0._wp 631 ENDIF ! IF (dhdt >= 0) 632 ENDIF ! IF (lconv) 633 END_2D 634 635 ! Average over the depth of the mixed layer in the convective boundary layer 636 ! Also calculate entrainment fluxes for temperature and salinity 637 DO_2D( 0, 0, 0, 0 ) 638 zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 639 zbeta = rab_n(ji,jj,1,jp_sal) 640 IF ( lconv(ji,jj) ) THEN 641 zt = 0._wp 642 zs = 0._wp 643 zu = 0._wp 644 zv = 0._wp 645 ! average over depth of boundary layer 646 zthick=0._wp 647 DO jm = 2, imld(ji,jj) 648 zthick=zthick+e3t(ji,jj,jm,Kmm) 649 zt = zt + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_tem,Kmm) 650 zs = zs + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_sal,Kmm) 651 zu = zu + e3t(ji,jj,jm,Kmm) & 652 & * ( uu(ji,jj,jm,Kbb) + uu(ji - 1,jj,jm,Kbb) ) & 653 & / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) 654 zv = zv + e3t(ji,jj,jm,Kmm) & 655 & * ( vv(ji,jj,jm,Kbb) + vv(ji,jj - 1,jm,Kbb) ) & 656 & / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) 657 END DO 658 zt_ml(ji,jj) = zt / zthick 659 zs_ml(ji,jj) = zs / zthick 660 zu_ml(ji,jj) = zu / zthick 661 zv_ml(ji,jj) = zv / zthick 662 zdt_ml(ji,jj) = zt_ml(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_tem,Kmm) 663 zds_ml(ji,jj) = zs_ml(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_sal,Kmm) 664 zdu_ml(ji,jj) = zu_ml(ji,jj) - ( uu(ji,jj,ibld(ji,jj),Kbb) + uu(ji-1,jj,ibld(ji,jj) ,Kbb) ) & 665 & / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) 666 zdv_ml(ji,jj) = zv_ml(ji,jj) - ( vv(ji,jj,ibld(ji,jj),Kbb) + vv(ji,jj-1,ibld(ji,jj) ,Kbb) ) & 667 & / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) 668 zdb_ml(ji,jj) = grav * zthermal * zdt_ml(ji,jj) - grav * zbeta * zds_ml(ji,jj) 669 ELSE 670 ! stable, if entraining calulate average below interface layer. 671 IF ( zdhdt(ji,jj) >= 0._wp ) THEN 672 zt = 0._wp 673 zs = 0._wp 674 zu = 0._wp 675 zv = 0._wp 676 ! average over depth of boundary layer 677 zthick=0._wp 678 DO jm = 2, imld(ji,jj) 679 zthick=zthick+e3t(ji,jj,jm,Kmm) 680 zt = zt + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_tem,Kmm) 681 zs = zs + e3t(ji,jj,jm,Kmm) * ts(ji,jj,jm,jp_sal,Kmm) 682 zu = zu + e3t(ji,jj,jm,Kmm) & 683 & * ( uu(ji,jj,jm,Kbb) + uu(ji - 1,jj,jm,Kbb) ) & 684 & / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) 685 zv = zv + e3t(ji,jj,jm,Kmm) & 686 & * ( vv(ji,jj,jm,Kbb) + vv(ji,jj - 1,jm,Kbb) ) & 687 & / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) 688 END DO 689 zt_ml(ji,jj) = zt / zthick 690 zs_ml(ji,jj) = zs / zthick 691 zu_ml(ji,jj) = zu / zthick 692 zv_ml(ji,jj) = zv / zthick 693 zdt_ml(ji,jj) = zt_ml(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_tem,Kmm) 694 zds_ml(ji,jj) = zs_ml(ji,jj) - ts(ji,jj,ibld(ji,jj),jp_sal,Kmm) 695 zdu_ml(ji,jj) = zu_ml(ji,jj) - ( uu(ji,jj,ibld(ji,jj),Kbb) + uu(ji-1,jj,ibld(ji,jj) ,Kbb) ) & 696 & / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) 697 zdv_ml(ji,jj) = zv_ml(ji,jj) - ( vv(ji,jj,ibld(ji,jj),Kbb) + vv(ji,jj-1,ibld(ji,jj) ,Kbb) ) & 698 & / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) 699 zdb_ml(ji,jj) = grav * zthermal * zdt_ml(ji,jj) - grav * zbeta * zds_ml(ji,jj) 700 ENDIF 701 ENDIF 702 END_2D 703 ! 677 ! Average over the depth of the mixed layer in the convective boundary layer 678 ! jp_ext = ibld - imld +1 679 CALL zdf_osm_vertical_average( imld-1, ibld-imld+1, zt_ml, zs_ml, zb_ml, zu_ml, zv_ml, zdt_ml, zds_ml, zdb_ml, zdu_ml, zdv_ml ) 704 680 ! rotate mean currents and changes onto wind align co-ordinates 705 681 ! 706 707 DO_2D( 0, 0, 0, 0 ) 708 ztemp = zu_ml(ji,jj) 709 zu_ml(ji,jj) = zu_ml(ji,jj) * zcos_wind(ji,jj) + zv_ml(ji,jj) * zsin_wind(ji,jj) 710 zv_ml(ji,jj) = zv_ml(ji,jj) * zcos_wind(ji,jj) - ztemp * zsin_wind(ji,jj) 711 ztemp = zdu_ml(ji,jj) 712 zdu_ml(ji,jj) = zdu_ml(ji,jj) * zcos_wind(ji,jj) + zdv_ml(ji,jj) * zsin_wind(ji,jj) 713 zdv_ml(ji,jj) = zdv_ml(ji,jj) * zsin_wind(ji,jj) - ztemp * zsin_wind(ji,jj) 714 ! 715 ztemp = zu_bl(ji,jj) 716 zu_bl = zu_bl(ji,jj) * zcos_wind(ji,jj) + zv_bl(ji,jj) * zsin_wind(ji,jj) 717 zv_bl(ji,jj) = zv_bl(ji,jj) * zcos_wind(ji,jj) - ztemp * zsin_wind(ji,jj) 718 ztemp = zdu_bl(ji,jj) 719 zdu_bl(ji,jj) = zdu_bl(ji,jj) * zcos_wind(ji,jj) + zdv_bl(ji,jj) * zsin_wind(ji,jj) 720 zdv_bl(ji,jj) = zdv_bl(ji,jj) * zsin_wind(ji,jj) - ztemp * zsin_wind(ji,jj) 721 END_2D 722 723 zuw_bse = 0._wp 724 zvw_bse = 0._wp 725 DO_2D( 0, 0, 0, 0 ) 726 727 IF ( lconv(ji,jj) ) THEN 728 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 729 zwth_ent(ji,jj) = zwb_ent(ji,jj) * zdt_ml(ji,jj) / (zdb_ml(ji,jj) + epsln) 730 zws_ent(ji,jj) = zwb_ent(ji,jj) * zds_ml(ji,jj) / (zdb_ml(ji,jj) + epsln) 731 ENDIF 732 ELSE 733 zwth_ent(ji,jj) = -2.0 * zwthav(ji,jj) * ( (1.0 - 0.8) - ( 1.0 - 0.8)**(3.0/2.0) ) 734 zws_ent(ji,jj) = -2.0 * zwsav(ji,jj) * ( (1.0 - 0.8 ) - ( 1.0 - 0.8 )**(3.0/2.0) ) 735 ENDIF 736 END_2D 737 682 CALL zdf_osm_velocity_rotation( zcos_wind, zsin_wind, zu_ml, zv_ml, zdu_ml, zdv_ml ) 683 CALL zdf_osm_velocity_rotation( zcos_wind, zsin_wind, zu_bl, zv_bl, zdu_bl, zdv_bl ) 738 684 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 739 685 ! Pycnocline gradients for scalars and velocity 740 686 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 741 687 742 DO_2D( 0, 0, 0, 0 ) 743 ! 744 IF ( lconv (ji,jj) ) THEN 745 ! Unstable conditions 746 IF( zdb_bl(ji,jj) > 0._wp ) THEN 747 ! calculate pycnocline profiles, no need if zdb_bl <= 0. since profile is zero and arrays have been initialized to zero 748 ztgrad = ( zdt_ml(ji,jj) / zdh(ji,jj) ) 749 zsgrad = ( zds_ml(ji,jj) / zdh(ji,jj) ) 750 zbgrad = ( zdb_ml(ji,jj) / zdh(ji,jj) ) 751 DO jk = 2 , ibld(ji,jj) 752 znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 753 zdtdz_pyc(ji,jj,jk) = ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 754 zdbdz_pyc(ji,jj,jk) = zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 755 zdsdz_pyc(ji,jj,jk) = zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 756 END DO 757 ENDIF 758 ELSE 759 ! stable conditions 760 ! if pycnocline profile only defined when depth steady of increasing. 761 IF ( zdhdt(ji,jj) >= 0.0 ) THEN ! Depth increasing, or steady. 762 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 763 IF ( zhol(ji,jj) >= 0.5 ) THEN ! Very stable - 'thick' pycnocline 764 ztgrad = zdt_bl(ji,jj) / zhbl(ji,jj) 765 zsgrad = zds_bl(ji,jj) / zhbl(ji,jj) 766 zbgrad = zdb_bl(ji,jj) / zhbl(ji,jj) 767 DO jk = 2, ibld(ji,jj) 768 znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 769 zdtdz_pyc(ji,jj,jk) = ztgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 770 zdbdz_pyc(ji,jj,jk) = zbgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 771 zdsdz_pyc(ji,jj,jk) = zsgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 772 END DO 773 ELSE ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form. 774 ztgrad = zdt_bl(ji,jj) / zdh(ji,jj) 775 zsgrad = zds_bl(ji,jj) / zdh(ji,jj) 776 zbgrad = zdb_bl(ji,jj) / zdh(ji,jj) 777 DO jk = 2, ibld(ji,jj) 778 znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 779 zdtdz_pyc(ji,jj,jk) = ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 780 zdbdz_pyc(ji,jj,jk) = zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 781 zdsdz_pyc(ji,jj,jk) = zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 782 END DO 783 ENDIF ! IF (zhol >=0.5) 784 ENDIF ! IF (zdb_bl> 0.) 785 ENDIF ! IF (zdhdt >= 0) zdhdt < 0 not considered since pycnocline profile is zero, profile arrays are intialized to zero 786 ENDIF ! IF (lconv) 787 ! 788 END_2D 789 ! 790 DO_2D( 0, 0, 0, 0 ) 791 ! 792 IF ( lconv (ji,jj) ) THEN 793 ! Unstable conditions 794 zugrad = ( zdu_ml(ji,jj) / zdh(ji,jj) ) + 0.275 * zustar(ji,jj)*zustar(ji,jj) / & 795 & (( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zhml(ji,jj) ) / zla(ji,jj)**(8.0/3.0) 796 zvgrad = ( zdv_ml(ji,jj) / zdh(ji,jj) ) + 3.5 * ff_t(ji,jj) * zustke(ji,jj) / & 797 & ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 798 DO jk = 2 , ibld(ji,jj)-1 799 znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 800 zdudz_pyc(ji,jj,jk) = zugrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 801 zdvdz_pyc(ji,jj,jk) = zvgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 802 END DO 803 ELSE 804 ! stable conditions 805 zugrad = 3.25 * zdu_bl(ji,jj) / zhbl(ji,jj) 806 zvgrad = 2.75 * zdv_bl(ji,jj) / zhbl(ji,jj) 807 DO jk = 2, ibld(ji,jj) 808 znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 809 IF ( znd < 1.0 ) THEN 810 zdudz_pyc(ji,jj,jk) = zugrad * EXP( -40.0 * ( znd - 1.0 )**2 ) 811 ELSE 812 zdudz_pyc(ji,jj,jk) = zugrad * EXP( -20.0 * ( znd - 1.0 )**2 ) 813 ENDIF 814 zdvdz_pyc(ji,jj,jk) = zvgrad * EXP( -20.0 * ( znd - 0.85 )**2 ) 815 END DO 816 ENDIF 817 ! 818 END_2D 688 CALL zdf_osm_external_gradients( ibld+2, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext ) 689 CALL zdf_osm_pycnocline_scalar_profiles( zdtdz_pyc, zdsdz_pyc, zdbdz_pyc, zalpha_pyc ) 690 CALL zdf_osm_pycnocline_shear_profiles( zdudz_pyc, zdvdz_pyc ) 819 691 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 820 692 ! Eddy viscosity/diffusivity and non-gradient terms in the flux-gradient relationship 821 693 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 822 823 ! WHERE ( lconv ) 824 ! zdifml_sc = zhml * ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird 825 ! zvisml_sc = zdifml_sc 826 ! zdifpyc_sc = 0.165 * ( zwstrl**3 + zwstrc**3 )**pthird * ( zhbl - zhml ) 827 ! zvispyc_sc = 0.142 * ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * ( zhbl - zhml ) 828 ! zbeta_d_sc = 1.0 - (0.165 / 0.8 * ( zhbl - zhml ) / zhbl )**p2third 829 ! zbeta_v_sc = 1.0 - 2.0 * (0.142 /0.375) * (zhbl - zhml ) / zhml 830 ! ELSEWHERE 831 ! zdifml_sc = zwstrl * zhbl * EXP ( -( zhol / 0.183_wp )**2 ) 832 ! zvisml_sc = zwstrl * zhbl * EXP ( -( zhol / 0.183_wp )**2 ) 833 ! ENDWHERE 834 DO_2D( 0, 0, 0, 0 ) 835 IF ( lconv(ji,jj) ) THEN 836 zdifml_sc(ji,jj) = zhml(ji,jj) * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 837 zvisml_sc(ji,jj) = zdifml_sc(ji,jj) 838 zdifpyc_sc(ji,jj) = 0.165 * ( zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3 )**pthird * zdh(ji,jj) 839 zvispyc_sc(ji,jj) = 0.142 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zdh(ji,jj) 840 zbeta_d_sc(ji,jj) = 1.0 - (0.165 / 0.8 * zdh(ji,jj) / zhbl(ji,jj) )**p2third 841 zbeta_v_sc(ji,jj) = 1.0 - 2.0 * (0.142 /0.375) * zdh(ji,jj) / zhml(ji,jj) 842 ELSE 843 zdifml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ) 844 zvisml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ) 845 END IF 846 END_2D 847 ! 848 DO_2D( 0, 0, 0, 0 ) 849 IF ( lconv(ji,jj) ) THEN 850 DO jk = 2, imld(ji,jj) ! mixed layer diffusivity 851 zznd_ml = gdepw(ji,jj,jk,Kmm) / zhml(ji,jj) 852 ! 853 zdiffut(ji,jj,jk) = 0.8 * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_d_sc(ji,jj) * zznd_ml )**1.5 854 ! 855 zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_v_sc(ji,jj) * zznd_ml ) & 856 & * ( 1.0 - 0.5 * zznd_ml**2 ) 857 END DO 858 ! pycnocline - if present linear profile 859 IF ( zdh(ji,jj) > 0._wp ) THEN 860 DO jk = imld(ji,jj)+1 , ibld(ji,jj) 861 zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 862 ! 863 zdiffut(ji,jj,jk) = zdifpyc_sc(ji,jj) * ( 1.0 + zznd_pyc ) 864 ! 865 zviscos(ji,jj,jk) = zvispyc_sc(ji,jj) * ( 1.0 + zznd_pyc ) 866 END DO 867 ENDIF 868 ! Temporay fix to ensure zdiffut is +ve; won't be necessary with ww taken out 869 zdiffut(ji,jj,ibld(ji,jj)) = zdhdt(ji,jj)* e3t(ji,jj,ibld(ji,jj),Kmm) 870 ! could be taken out, take account of entrainment represents as a diffusivity 871 ! should remove w from here, represents entrainment 872 ELSE 873 ! stable conditions 874 DO jk = 2, ibld(ji,jj) 875 zznd_ml = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 876 zdiffut(ji,jj,jk) = 0.75 * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zznd_ml )**1.5 877 zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * (1.0 - zznd_ml) * ( 1.0 - zznd_ml**2 ) 878 END DO 879 ENDIF ! end if ( lconv ) 880 ! 881 END_2D 694 CALL zdf_osm_diffusivity_viscosity( zdiffut, zviscos ) 882 695 883 696 ! … … 918 731 END_2D 919 732 920 921 733 ! Stokes term in flux-gradient relationship (note in zsc_uw_n don't use zvstr since term needs to go to zero as zwstrl goes to zero) 922 734 WHERE ( lconv ) 923 zsc_uw_1 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke / ( 1.0 - 1.0 * 6.5 * zla**(8.0/3.0))924 zsc_uw_2 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke / ( zla**(8.0/3.0) + epsln)925 zsc_vw_1 = ff_t * zhml * zustke**3 * zla**(8.0/3.0) / ( ( zvstr**3 + 0.5 * zwstrc**3 )**(2.0/3.0) + epsln )735 zsc_uw_1 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke / MAX( ( 1.0 - 1.0 * 6.5 * zla**(8.0/3.0) ), 0.2 ) 736 zsc_uw_2 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke / MIN( zla**(8.0/3.0) + epsln, 0.12 ) 737 zsc_vw_1 = ff_t * zhml * zustke**3 * MIN( zla**(8.0/3.0), 0.12 ) / ( ( zvstr**3 + 0.5 * zwstrc**3 )**(2.0/3.0) + epsln ) 926 738 ELSEWHERE 927 739 zsc_uw_1 = zustar**2 928 zsc_vw_1 = ff_t * zhbl * zustke**3 * zla**(8.0/3.0) / (zvstr**2 + epsln)740 zsc_vw_1 = ff_t * zhbl * zustke**3 * MIN( zla**(8.0/3.0), 0.12 ) / (zvstr**2 + epsln) 929 741 ENDWHERE 930 742 IF(ln_dia_osm) THEN 743 IF ( iom_use("ghamu_00") ) CALL iom_put( "ghamu_00", wmask*ghamu ) 744 IF ( iom_use("ghamv_00") ) CALL iom_put( "ghamv_00", wmask*ghamv ) 745 END IF 931 746 DO_2D( 0, 0, 0, 0 ) 932 747 IF ( lconv(ji,jj) ) THEN … … 970 785 zl_l = 2.0 * ( 1.0 - EXP ( - 2.0 * ( zznd_ml - zznd_ml**3 / 3.0 ) ) ) & 971 786 & * ( 1.0 - EXP ( - 5.0 * ( 1.0 - zznd_ml ) ) ) * ( 1.0 + dstokes(ji,jj) / zhml (ji,jj) ) 972 zl_eps = zl_l + ( zl_c - zl_l ) / ( 1.0 + EXP ( 3.0 * LOG10 ( - zhol(ji,jj) ) ) ) ** (3.0/2.0)787 zl_eps = zl_l + ( zl_c - zl_l ) / ( 1.0 + EXP ( -3.0 * LOG10 ( - zhol(ji,jj) ) ) ) ** (3.0 / 2.0) 973 788 ! non-gradient buoyancy terms 974 789 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * 0.5 * zsc_wth_1(ji,jj) * zl_eps * zhml(ji,jj) / ( 0.15 + zznd_ml ) 975 790 ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * 0.5 * zsc_ws_1(ji,jj) * zl_eps * zhml(ji,jj) / ( 0.15 + zznd_ml ) 976 791 END DO 977 ELSE 792 793 IF ( lpyc(ji,jj) ) THEN 794 ztau_sc_u(ji,jj) = zhml(ji,jj) / ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird 795 ztau_sc_u(ji,jj) = ztau_sc_u(ji,jj) * ( 1.4 -0.4 / ( 1.0 + EXP( -3.5 * LOG10( -zhol(ji,jj) ) ) )**1.5 ) 796 zwth_ent = -0.003 * ( 0.15 * zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird * ( 1.0 - zdh(ji,jj) /zhbl(ji,jj) ) * zdt_ml(ji,jj) 797 zws_ent = -0.003 * ( 0.15 * zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird * ( 1.0 - zdh(ji,jj) /zhbl(ji,jj) ) * zds_ml(ji,jj) 798 ! Cubic profile used for buoyancy term 799 za_cubic = 0.755 * ztau_sc_u(ji,jj) 800 zb_cubic = 0.25 * ztau_sc_u(ji,jj) 801 DO jk = 2, ibld(ji,jj) 802 zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zdh(ji,jj) 803 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) - 0.045 * ( ( zwth_ent * zdbdz_pyc(ji,jj,jk) ) * ztau_sc_u(ji,jj)**2 ) * MAX( ( 1.75 * zznd_pyc -0.15 * zznd_pyc**2 - 0.2 * zznd_pyc**3 ), 0.0 ) 804 805 ghams(ji,jj,jk) = ghams(ji,jj,jk) - 0.045 * ( ( zws_ent * zdbdz_pyc(ji,jj,jk) ) * ztau_sc_u(ji,jj)**2 ) * MAX( ( 1.75 * zznd_pyc -0.15 * zznd_pyc**2 - 0.2 * zznd_pyc**3 ), 0.0 ) 806 END DO 807 ! 808 zbuoy_pyc_sc = zalpha_pyc(ji,jj) * zdb_ml(ji,jj) / zdh(ji,jj) + zdbdz_bl_ext(ji,jj) 809 zdelta_pyc = ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird / SQRT( MAX( zbuoy_pyc_sc, ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**p2third / zdh(ji,jj)**2 ) ) 810 ! 811 zwt_pyc_sc_1 = 0.325 * ( zalpha_pyc(ji,jj) * zdt_ml(ji,jj) / zdh(ji,jj) + zdtdz_bl_ext(ji,jj) ) * zdelta_pyc**2 / zdh(ji,jj) 812 ! 813 zws_pyc_sc_1 = 0.325 * ( zalpha_pyc(ji,jj) * zds_ml(ji,jj) / zdh(ji,jj) + zdsdz_bl_ext(ji,jj) ) * zdelta_pyc**2 / zdh(ji,jj) 814 ! 815 zzeta_pyc = 0.15 - 0.175 / ( 1.0 + EXP( -3.5 * LOG10( -zhol(ji,jj) ) ) ) 816 DO jk = 2, ibld(ji,jj) 817 zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zdh(ji,jj) 818 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.05 * zwt_pyc_sc_1 * EXP( -0.25 * ( zznd_pyc / zzeta_pyc )**2 ) * zdh(ji,jj) / ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird 819 ! 820 ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.05 * zws_pyc_sc_1 * EXP( -0.25 * ( zznd_pyc / zzeta_pyc )**2 ) * zdh(ji,jj) / ( zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 )**pthird 821 END DO 822 ENDIF ! End of pycnocline 823 ELSE ! lconv test - stable conditions 978 824 DO jk = 2, ibld(ji,jj) 979 825 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zsc_wth_1(ji,jj) … … 982 828 ENDIF 983 829 END_2D 984 985 830 986 831 WHERE ( lconv ) … … 1011 856 END_2D 1012 857 858 DO_2D( 0, 0, 0, 0 ) 859 IF ( lpyc(ji,jj) ) THEN 860 IF ( j_ddh(ji,jj) == 0 ) THEN 861 ! Place holding code. Parametrization needs checking for these conditions. 862 zomega = ( 0.15 * zwstrl(ji,jj)**3 + zwstrc(ji,jj)**3 + 4.75 * ( zshear(ji,jj)* zhbl(ji,jj) )**pthird )**pthird 863 zuw_bse = -0.0035 * zomega * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zdu_ml(ji,jj) 864 zvw_bse = -0.0075 * zomega * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zdv_ml(ji,jj) 865 ELSE 866 zomega = ( 0.15 * zwstrl(ji,jj)**3 + zwstrc(ji,jj)**3 + 4.75 * ( zshear(ji,jj)* zhbl(ji,jj) )**pthird )**pthird 867 zuw_bse = -0.0035 * zomega * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zdu_ml(ji,jj) 868 zvw_bse = -0.0075 * zomega * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zdv_ml(ji,jj) 869 ENDIF 870 zd_cubic = zdh(ji,jj) / zhbl(ji,jj) * zuw0(ji,jj) - ( 2.0 + zdh(ji,jj) /zhml(ji,jj) ) * zuw_bse 871 zc_cubic = zuw_bse - zd_cubic 872 ! need ztau_sc_u to be available. Change to array. 873 DO jk = imld(ji,jj), ibld(ji,jj) 874 zznd_pyc = - ( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zdh(ji,jj) 875 ghamu(ji,jj,jk) = ghamu(ji,jj,jk) - 0.045 * ztau_sc_u(ji,jj)**2 * ( zc_cubic * zznd_pyc**2 + zd_cubic * zznd_pyc**3 ) * ( 0.75 + 0.25 * zznd_pyc )**2 * zdbdz_pyc(ji,jj,jk) 876 END DO 877 zvw_max = 0.7 * ff_t(ji,jj) * ( zustke(ji,jj) * dstokes(ji,jj) + 0.75 * zustar(ji,jj) * zhml(ji,jj) ) 878 zd_cubic = zvw_max * zdh(ji,jj) / zhml(ji,jj) - ( 2.0 + zdh(ji,jj) /zhml(ji,jj) ) * zvw_bse 879 zc_cubic = zvw_bse - zd_cubic 880 DO jk = imld(ji,jj), ibld(ji,jj) 881 zznd_pyc = -( gdepw(ji,jj,jk,Kmm) -zhbl(ji,jj) ) / zdh(ji,jj) 882 ghamv(ji,jj,jk) = ghamv(ji,jj,jk) - 0.045 * ztau_sc_u(ji,jj)**2 * ( zc_cubic * zznd_pyc**2 + zd_cubic * zznd_pyc**3 ) * ( 0.75 + 0.25 * zznd_pyc )**2 * zdbdz_pyc(ji,jj,jk) 883 END DO 884 ENDIF ! lpyc 885 END_2D 886 887 IF(ln_dia_osm) THEN 888 IF ( iom_use("ghamu_0") ) CALL iom_put( "ghamu_0", wmask*ghamu ) 889 IF ( iom_use("zsc_uw_1_0") ) CALL iom_put( "zsc_uw_1_0", tmask(:,:,1)*zsc_uw_1 ) 890 END IF 1013 891 ! Transport term in flux-gradient relationship [note : includes ROI ratio (X0.3) ] 1014 892 1015 WHERE ( lconv ) 1016 zsc_wth_1 = zwth0 1017 zsc_ws_1 = zws0 1018 ELSEWHERE 1019 zsc_wth_1 = 2.0 * zwthav 1020 zsc_ws_1 = zws0 1021 ENDWHERE 893 DO_2D( 1, 0, 1, 0 ) 894 895 IF ( lconv(ji,jj) ) THEN 896 zsc_wth_1(ji,jj) = zwth0(ji,jj) / ( 1.0 - 0.56 * EXP( zhol(ji,jj) ) ) 897 zsc_ws_1(ji,jj) = zws0(ji,jj) / (1.0 - 0.56 *EXP( zhol(ji,jj) ) ) 898 IF ( lpyc(ji,jj) ) THEN 899 ! Pycnocline scales 900 zsc_wth_pyc(ji,jj) = -0.2 * zwb0(ji,jj) * zdt_bl(ji,jj) / zdb_bl(ji,jj) 901 zsc_ws_pyc(ji,jj) = -0.2 * zwb0(ji,jj) * zds_bl(ji,jj) / zdb_bl(ji,jj) 902 ENDIF 903 ELSE 904 zsc_wth_1(ji,jj) = 2.0 * zwthav(ji,jj) 905 zsc_ws_1(ji,jj) = zws0(ji,jj) 906 ENDIF 907 END_2D 1022 908 1023 909 DO_2D( 0, 0, 0, 0 ) … … 1035 921 & * ( 1.0 - EXP ( -15.0 * ( 1.0 - zznd_ml ) ) ) 1036 922 END DO 923 ! 924 IF ( lpyc(ji,jj) ) THEN 925 ! pycnocline 926 DO jk = imld(ji,jj), ibld(ji,jj) 927 zznd_pyc = - ( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zdh(ji,jj) 928 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 4.0 * zsc_wth_pyc(ji,jj) * ( 0.48 - EXP( -1.5 * ( zznd_pyc -0.3)**2 ) ) 929 ghams(ji,jj,jk) = ghams(ji,jj,jk) + 4.0 * zsc_ws_pyc(ji,jj) * ( 0.48 - EXP( -1.5 * ( zznd_pyc -0.3)**2 ) ) 930 END DO 931 ENDIF 1037 932 ELSE 1038 DO jk = 2, ibld(ji,jj) 1039 zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) 1040 znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 1041 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & 1042 & 7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_wth_1(ji,jj) 1043 ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & 1044 & 7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_ws_1(ji,jj) 1045 END DO 933 IF( zdhdt(ji,jj) > 0. ) THEN 934 DO jk = 2, ibld(ji,jj) 935 zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) 936 znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 937 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & 938 & 7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_wth_1(ji,jj) 939 ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & 940 & 7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_ws_1(ji,jj) 941 END DO 942 ENDIF 1046 943 ENDIF 1047 944 END_2D 1048 1049 945 1050 946 WHERE ( lconv ) … … 1090 986 ENDIF 1091 987 END_2D 988 989 IF(ln_dia_osm) THEN 990 IF ( iom_use("ghamu_f") ) CALL iom_put( "ghamu_f", wmask*ghamu ) 991 IF ( iom_use("ghamv_f") ) CALL iom_put( "ghamv_f", wmask*ghamv ) 992 IF ( iom_use("zsc_uw_1_f") ) CALL iom_put( "zsc_uw_1_f", tmask(:,:,1)*zsc_uw_1 ) 993 IF ( iom_use("zsc_vw_1_f") ) CALL iom_put( "zsc_vw_1_f", tmask(:,:,1)*zsc_vw_1 ) 994 IF ( iom_use("zsc_uw_2_f") ) CALL iom_put( "zsc_uw_2_f", tmask(:,:,1)*zsc_uw_2 ) 995 IF ( iom_use("zsc_vw_2_f") ) CALL iom_put( "zsc_vw_2_f", tmask(:,:,1)*zsc_vw_2 ) 996 END IF 1092 997 ! 1093 998 ! Make surface forced velocity non-gradient terms go to zero at the base of the mixed layer. 1094 999 1000 1001 ! Make surface forced velocity non-gradient terms go to zero at the base of the boundary layer. 1002 1095 1003 DO_2D( 0, 0, 0, 0 ) 1096 IF ( lconv(ji,jj) ) THEN1004 IF ( .not. lconv(ji,jj) ) THEN 1097 1005 DO jk = 2, ibld(ji,jj) 1098 znd = ( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zhml(ji,jj) !ALMG to think about 1099 IF ( znd >= 0.0 ) THEN 1100 ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0 - EXP( -30.0 * znd**2 ) ) 1101 ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * ( 1.0 - EXP( -30.0 * znd**2 ) ) 1102 ELSE 1103 ghamu(ji,jj,jk) = 0._wp 1104 ghamv(ji,jj,jk) = 0._wp 1105 ENDIF 1106 END DO 1107 ELSE 1108 DO jk = 2, ibld(ji,jj) 1109 znd = ( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zhml(ji,jj) !ALMG to think about 1006 znd = ( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / zhbl(ji,jj) !ALMG to think about 1110 1007 IF ( znd >= 0.0 ) THEN 1111 1008 ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0 - EXP( -10.0 * znd**2 ) ) … … 1120 1017 1121 1018 ! pynocline contributions 1122 ! Temporary fix to avoid instabilities when zdb_bl becomes very very small1123 zsc_uw_1 = 0._wp ! 50.0 * zla**(8.0/3.0) * zustar**2 * zhbl / ( zdb_bl + epsln )1124 1019 DO_2D( 0, 0, 0, 0 ) 1125 DO jk= 2, ibld(ji,jj) 1126 znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 1127 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zdiffut(ji,jj,jk) * zdtdz_pyc(ji,jj,jk) 1128 ghams(ji,jj,jk) = ghams(ji,jj,jk) + zdiffut(ji,jj,jk) * zdsdz_pyc(ji,jj,jk) 1129 ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zviscos(ji,jj,jk) * zdudz_pyc(ji,jj,jk) 1130 ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zsc_uw_1(ji,jj) * ( 1.0 - znd )**(7.0/4.0) * zdbdz_pyc(ji,jj,jk) 1131 ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zviscos(ji,jj,jk) * zdvdz_pyc(ji,jj,jk) 1132 END DO 1020 IF ( .not. lconv(ji,jj) ) THEN 1021 IF ( ibld(ji,jj) + jp_ext(ji,jj) < mbkt(ji,jj) ) THEN 1022 DO jk= 2, ibld(ji,jj) 1023 znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 1024 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zdiffut(ji,jj,jk) * zdtdz_pyc(ji,jj,jk) 1025 ghams(ji,jj,jk) = ghams(ji,jj,jk) + zdiffut(ji,jj,jk) * zdsdz_pyc(ji,jj,jk) 1026 ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zviscos(ji,jj,jk) * zdudz_pyc(ji,jj,jk) 1027 ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zviscos(ji,jj,jk) * zdvdz_pyc(ji,jj,jk) 1028 END DO 1029 END IF 1030 END IF 1133 1031 END_2D 1134 1135 ! Entrainment contribution. 1032 IF(ln_dia_osm) THEN 1033 IF ( iom_use("ghamu_b") ) CALL iom_put( "ghamu_b", wmask*ghamu ) 1034 IF ( iom_use("ghamv_b") ) CALL iom_put( "ghamv_b", wmask*ghamv ) 1035 END IF 1136 1036 1137 1037 DO_2D( 0, 0, 0, 0 ) 1138 IF ( lconv(ji,jj) ) THEN 1139 DO jk = 1, imld(ji,jj) - 1 1140 znd=gdepw(ji,jj,jk,Kmm) / zhml(ji,jj) 1141 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth_ent(ji,jj) * znd 1142 ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws_ent(ji,jj) * znd 1143 ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zuw_bse(ji,jj) * znd 1144 ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zvw_bse(ji,jj) * znd 1145 END DO 1146 DO jk = imld(ji,jj), ibld(ji,jj) 1147 znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) / zdh(ji,jj) 1148 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth_ent(ji,jj) * ( 1.0 + znd ) 1149 ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws_ent(ji,jj) * ( 1.0 + znd ) 1150 ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zuw_bse(ji,jj) * ( 1.0 + znd ) 1151 ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zvw_bse(ji,jj) * ( 1.0 + znd ) 1152 END DO 1153 ENDIF 1154 ghamt(ji,jj,ibld(ji,jj)) = 0._wp 1155 ghams(ji,jj,ibld(ji,jj)) = 0._wp 1156 ghamu(ji,jj,ibld(ji,jj)) = 0._wp 1157 ghamv(ji,jj,ibld(ji,jj)) = 0._wp 1038 ghamt(ji,jj,ibld(ji,jj)+ibld_ext) = 0._wp 1039 ghams(ji,jj,ibld(ji,jj)+ibld_ext) = 0._wp 1040 ghamu(ji,jj,ibld(ji,jj)+ibld_ext) = 0._wp 1041 ghamv(ji,jj,ibld(ji,jj)+ibld_ext) = 0._wp 1158 1042 END_2D 1159 1043 1160 1044 IF(ln_dia_osm) THEN 1045 IF ( iom_use("ghamu_1") ) CALL iom_put( "ghamu_1", wmask*ghamu ) 1046 IF ( iom_use("ghamv_1") ) CALL iom_put( "ghamv_1", wmask*ghamv ) 1047 IF ( iom_use("zdudz_pyc") ) CALL iom_put( "zdudz_pyc", wmask*zdudz_pyc ) 1048 IF ( iom_use("zdvdz_pyc") ) CALL iom_put( "zdvdz_pyc", wmask*zdvdz_pyc ) 1049 IF ( iom_use("zviscos") ) CALL iom_put( "zviscos", wmask*zviscos ) 1050 END IF 1161 1051 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 1162 1052 ! Need to put in code for contributions that are applied explicitly to … … 1180 1070 IF(ln_dia_osm) THEN 1181 1071 IF ( iom_use("zdtdz_pyc") ) CALL iom_put( "zdtdz_pyc", wmask*zdtdz_pyc ) 1072 IF ( iom_use("zdsdz_pyc") ) CALL iom_put( "zdsdz_pyc", wmask*zdsdz_pyc ) 1073 IF ( iom_use("zdbdz_pyc") ) CALL iom_put( "zdbdz_pyc", wmask*zdbdz_pyc ) 1182 1074 END IF 1183 1075 … … 1222 1114 END IF ! ln_convmix = .true. 1223 1115 1116 1117 1118 IF ( ln_osm_mle ) THEN ! set up diffusivity and non-gradient mixing 1119 DO_2D( 0, 0, 0, 0 ) 1120 IF ( lflux(ji,jj) ) THEN ! MLE mixing extends below boundary layer 1121 ! Calculate MLE flux contribution from surface fluxes 1122 DO jk = 1, ibld(ji,jj) 1123 znd = gdepw(ji,jj,jk,Kmm) / MAX(zhbl(ji,jj),epsln) 1124 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) - zwth0(ji,jj) * ( 1.0 - znd ) 1125 ghams(ji,jj,jk) = ghams(ji,jj,jk) - zws0(ji,jj) * ( 1.0 - znd ) 1126 END DO 1127 DO jk = 1, mld_prof(ji,jj) 1128 znd = gdepw(ji,jj,jk,Kmm) / MAX(zhmle(ji,jj),epsln) 1129 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth0(ji,jj) * ( 1.0 - znd ) 1130 ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws0(ji,jj) * ( 1.0 -znd ) 1131 END DO 1132 ! Viscosity for MLEs 1133 DO jk = 1, mld_prof(ji,jj) 1134 znd = -gdepw(ji,jj,jk,Kmm) / MAX(zhmle(ji,jj),epsln) 1135 zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdiff_mle(ji,jj) * ( 1.0 - ( 2.0 * znd + 1.0 )**2 ) * ( 1.0 + 5.0 / 21.0 * ( 2.0 * znd + 1.0 )** 2 ) 1136 END DO 1137 ELSE 1138 ! Surface transports limited to OSBL. 1139 ! Viscosity for MLEs 1140 DO jk = 1, mld_prof(ji,jj) 1141 znd = -gdepw(ji,jj,jk,Kmm) / MAX(zhmle(ji,jj),epsln) 1142 zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdiff_mle(ji,jj) * ( 1.0 - ( 2.0 * znd + 1.0 )**2 ) * ( 1.0 + 5.0 / 21.0 * ( 2.0 * znd + 1.0 )** 2 ) 1143 END DO 1144 ENDIF 1145 END_2D 1146 ENDIF 1147 1148 IF(ln_dia_osm) THEN 1149 IF ( iom_use("zdtdz_pyc") ) CALL iom_put( "zdtdz_pyc", wmask*zdtdz_pyc ) 1150 IF ( iom_use("zdsdz_pyc") ) CALL iom_put( "zdsdz_pyc", wmask*zdsdz_pyc ) 1151 IF ( iom_use("zdbdz_pyc") ) CALL iom_put( "zdbdz_pyc", wmask*zdbdz_pyc ) 1152 END IF 1153 1154 1224 1155 ! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids 1225 CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp )1156 !CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp ) 1226 1157 1227 1158 ! GN 25/8: need to change tmask --> wmask … … 1244 1175 ghams(ji,jj,jk) = ghams(ji,jj,jk) * tmask(ji,jj,jk) 1245 1176 END_3D 1177 ! Lateral boundary conditions on final outputs for hbl, on T-grid (sign unchanged) 1178 CALL lbc_lnk_multi( 'zdfosm', hbl, 'T', 1., dh, 'T', 1., hmle, 'T', 1. ) 1246 1179 ! Lateral boundary conditions on final outputs for gham[ts], on W-grid (sign unchanged) 1247 ! Lateral boundary conditions on final outputs for gham[uv], on [UV]-grid (sign unchanged)1248 CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1.0_wp , ghams, 'W',1.0_wp, &1249 & ghamu, 'U', 1.0_wp , ghamv, 'V',1.0_wp )1250 1251 1180 ! Lateral boundary conditions on final outputs for gham[uv], on [UV]-grid (sign changed) 1181 CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1.0_wp , ghams, 'W', 1.0_wp, & 1182 & ghamu, 'U', -1.0_wp , ghamv, 'V', -1.0_wp ) 1183 1184 IF(ln_dia_osm) THEN 1252 1185 SELECT CASE (nn_osm_wave) 1253 1186 ! Stokes drift set by assumimg onstant La#=0.3(=0) or Pierson-Moskovitz spectrum (=1). … … 1257 1190 IF ( iom_use("wind_wave_abs_power") ) CALL iom_put( "wind_wave_abs_power", 1000.*rho0*tmask(:,:,1)*zustar**2*zustke ) 1258 1191 ! Stokes drift read in from sbcwave (=2). 1259 CASE(2) 1260 IF ( iom_use("us_x") ) CALL iom_put( "us_x", ut0sd ) ! x surface Stokes drift 1261 IF ( iom_use("us_y") ) CALL iom_put( "us_y", vt0sd ) ! y surface Stokes drift 1192 CASE(2:3) 1193 IF ( iom_use("us_x") ) CALL iom_put( "us_x", ut0sd*umask(:,:,1) ) ! x surface Stokes drift 1194 IF ( iom_use("us_y") ) CALL iom_put( "us_y", vt0sd*vmask(:,:,1) ) ! y surface Stokes drift 1195 IF ( iom_use("wmp") ) CALL iom_put( "wmp", wmp*tmask(:,:,1) ) ! wave mean period 1196 IF ( iom_use("hsw") ) CALL iom_put( "hsw", hsw*tmask(:,:,1) ) ! significant wave height 1197 IF ( iom_use("wmp_NP") ) CALL iom_put( "wmp_NP", (2.*rpi*1.026/(0.877*grav) )*wndm*tmask(:,:,1) ) ! wave mean period from NP spectrum 1198 IF ( iom_use("hsw_NP") ) CALL iom_put( "hsw_NP", (0.22/grav)*wndm**2*tmask(:,:,1) ) ! significant wave height from NP spectrum 1199 IF ( iom_use("wndm") ) CALL iom_put( "wndm", wndm*tmask(:,:,1) ) ! U_10 1262 1200 IF ( iom_use("wind_wave_abs_power") ) CALL iom_put( "wind_wave_abs_power", 1000.*rho0*tmask(:,:,1)*zustar**2* & 1263 1201 & SQRT(ut0sd**2 + vt0sd**2 ) ) … … 1270 1208 IF ( iom_use("zws0") ) CALL iom_put( "zws0", tmask(:,:,1)*zws0 ) ! <Sw_0> 1271 1209 IF ( iom_use("hbl") ) CALL iom_put( "hbl", tmask(:,:,1)*hbl ) ! boundary-layer depth 1272 IF ( iom_use("hbli") ) CALL iom_put( "hbli", tmask(:,:,1)*hbli ) ! Initial boundary-layer depth 1210 IF ( iom_use("ibld") ) CALL iom_put( "ibld", tmask(:,:,1)*ibld ) ! boundary-layer max k 1211 IF ( iom_use("zdt_bl") ) CALL iom_put( "zdt_bl", tmask(:,:,1)*zdt_bl ) ! dt at ml base 1212 IF ( iom_use("zds_bl") ) CALL iom_put( "zds_bl", tmask(:,:,1)*zds_bl ) ! ds at ml base 1213 IF ( iom_use("zdb_bl") ) CALL iom_put( "zdb_bl", tmask(:,:,1)*zdb_bl ) ! db at ml base 1214 IF ( iom_use("zdu_bl") ) CALL iom_put( "zdu_bl", tmask(:,:,1)*zdu_bl ) ! du at ml base 1215 IF ( iom_use("zdv_bl") ) CALL iom_put( "zdv_bl", tmask(:,:,1)*zdv_bl ) ! dv at ml base 1216 IF ( iom_use("dh") ) CALL iom_put( "dh", tmask(:,:,1)*dh ) ! Initial boundary-layer depth 1217 IF ( iom_use("hml") ) CALL iom_put( "hml", tmask(:,:,1)*hml ) ! Initial boundary-layer depth 1273 1218 IF ( iom_use("dstokes") ) CALL iom_put( "dstokes", tmask(:,:,1)*dstokes ) ! Stokes drift penetration depth 1274 1219 IF ( iom_use("zustke") ) CALL iom_put( "zustke", tmask(:,:,1)*zustke ) ! Stokes drift magnitude at T-points … … 1276 1221 IF ( iom_use("zwstrl") ) CALL iom_put( "zwstrl", tmask(:,:,1)*zwstrl ) ! Langmuir velocity scale 1277 1222 IF ( iom_use("zustar") ) CALL iom_put( "zustar", tmask(:,:,1)*zustar ) ! friction velocity scale 1223 IF ( iom_use("zvstr") ) CALL iom_put( "zvstr", tmask(:,:,1)*zvstr ) ! mixed velocity scale 1224 IF ( iom_use("zla") ) CALL iom_put( "zla", tmask(:,:,1)*zla ) ! langmuir # 1278 1225 IF ( iom_use("wind_power") ) CALL iom_put( "wind_power", 1000.*rho0*tmask(:,:,1)*zustar**3 ) ! BL depth internal to zdf_osm routine 1279 1226 IF ( iom_use("wind_wave_power") ) CALL iom_put( "wind_wave_power", 1000.*rho0*tmask(:,:,1)*zustar**2*zustke ) 1280 1227 IF ( iom_use("zhbl") ) CALL iom_put( "zhbl", tmask(:,:,1)*zhbl ) ! BL depth internal to zdf_osm routine 1281 1228 IF ( iom_use("zhml") ) CALL iom_put( "zhml", tmask(:,:,1)*zhml ) ! ML depth internal to zdf_osm routine 1282 IF ( iom_use("zdh") ) CALL iom_put( "zdh", tmask(:,:,1)*zdh ) ! ML depth internal to zdf_osm routine 1229 IF ( iom_use("imld") ) CALL iom_put( "imld", tmask(:,:,1)*imld ) ! index for ML depth internal to zdf_osm routine 1230 IF ( iom_use("zdh") ) CALL iom_put( "zdh", tmask(:,:,1)*zdh ) ! pyc thicknessh internal to zdf_osm routine 1283 1231 IF ( iom_use("zhol") ) CALL iom_put( "zhol", tmask(:,:,1)*zhol ) ! ML depth internal to zdf_osm routine 1284 IF ( iom_use("zwthav") ) CALL iom_put( "zwthav", tmask(:,:,1)*zwthav ) ! ML depth internal to zdf_osm routine 1285 IF ( iom_use("zwth_ent") ) CALL iom_put( "zwth_ent", tmask(:,:,1)*zwth_ent ) ! ML depth internal to zdf_osm routine 1286 IF ( iom_use("zt_ml") ) CALL iom_put( "zt_ml", tmask(:,:,1)*zt_ml ) ! average T in ML 1232 IF ( iom_use("zwthav") ) CALL iom_put( "zwthav", tmask(:,:,1)*zwthav ) ! upward BL-avged turb temp flux 1233 IF ( iom_use("zwth_ent") ) CALL iom_put( "zwth_ent", tmask(:,:,1)*zwth_ent ) ! upward turb temp entrainment flux 1234 IF ( iom_use("zwb_ent") ) CALL iom_put( "zwb_ent", tmask(:,:,1)*zwb_ent ) ! upward turb buoyancy entrainment flux 1235 IF ( iom_use("zws_ent") ) CALL iom_put( "zws_ent", tmask(:,:,1)*zws_ent ) ! upward turb salinity entrainment flux 1236 IF ( iom_use("zt_ml") ) CALL iom_put( "zt_ml", tmask(:,:,1)*zt_ml ) ! average T in ML 1237 1238 IF ( iom_use("hmle") ) CALL iom_put( "hmle", tmask(:,:,1)*hmle ) ! FK layer depth 1239 IF ( iom_use("zmld") ) CALL iom_put( "zmld", tmask(:,:,1)*zmld ) ! FK target layer depth 1240 IF ( iom_use("zwb_fk") ) CALL iom_put( "zwb_fk", tmask(:,:,1)*zwb_fk ) ! FK b flux 1241 IF ( iom_use("zwb_fk_b") ) CALL iom_put( "zwb_fk_b", tmask(:,:,1)*zwb_fk_b ) ! FK b flux averaged over ML 1242 IF ( iom_use("mld_prof") ) CALL iom_put( "mld_prof", tmask(:,:,1)*mld_prof )! FK layer max k 1243 IF ( iom_use("zdtdx") ) CALL iom_put( "zdtdx", umask(:,:,1)*zdtdx ) ! FK dtdx at u-pt 1244 IF ( iom_use("zdtdy") ) CALL iom_put( "zdtdy", vmask(:,:,1)*zdtdy ) ! FK dtdy at v-pt 1245 IF ( iom_use("zdsdx") ) CALL iom_put( "zdsdx", umask(:,:,1)*zdsdx ) ! FK dtdx at u-pt 1246 IF ( iom_use("zdsdy") ) CALL iom_put( "zdsdy", vmask(:,:,1)*zdsdy ) ! FK dsdy at v-pt 1247 IF ( iom_use("dbdx_mle") ) CALL iom_put( "dbdx_mle", umask(:,:,1)*dbdx_mle ) ! FK dbdx at u-pt 1248 IF ( iom_use("dbdy_mle") ) CALL iom_put( "dbdy_mle", vmask(:,:,1)*dbdy_mle ) ! FK dbdy at v-pt 1249 IF ( iom_use("zdiff_mle") ) CALL iom_put( "zdiff_mle", tmask(:,:,1)*zdiff_mle )! FK diff in MLE at t-pt 1250 IF ( iom_use("zvel_mle") ) CALL iom_put( "zvel_mle", tmask(:,:,1)*zdiff_mle )! FK diff in MLE at t-pt 1251 1287 1252 END IF 1288 ! Lateral boundary conditions on p_avt (sign unchanged) 1289 CALL lbc_lnk( 'zdfosm', p_avt(:,:,:), 'W', 1.0_wp ) 1253 1254 CONTAINS 1255 ! subroutine code changed, needs syntax checking. 1256 SUBROUTINE zdf_osm_diffusivity_viscosity( zdiffut, zviscos ) 1257 1258 !!--------------------------------------------------------------------- 1259 !! *** ROUTINE zdf_osm_diffusivity_viscosity *** 1260 !! 1261 !! ** Purpose : Determines the eddy diffusivity and eddy viscosity profiles in the mixed layer and the pycnocline. 1262 !! 1263 !! ** Method : 1264 !! 1265 !! !!---------------------------------------------------------------------- 1266 REAL(wp), DIMENSION(:,:,:) :: zdiffut 1267 REAL(wp), DIMENSION(:,:,:) :: zviscos 1268 ! local 1269 1270 ! Scales used to calculate eddy diffusivity and viscosity profiles 1271 REAL(wp), DIMENSION(jpi,jpj) :: zdifml_sc, zvisml_sc 1272 REAL(wp), DIMENSION(jpi,jpj) :: zdifpyc_n_sc, zdifpyc_s_sc, zdifpyc_shr 1273 REAL(wp), DIMENSION(jpi,jpj) :: zvispyc_n_sc, zvispyc_s_sc,zvispyc_shr 1274 REAL(wp), DIMENSION(jpi,jpj) :: zbeta_d_sc, zbeta_v_sc 1275 ! 1276 REAL(wp) :: zvel_sc_pyc, zvel_sc_ml, zstab_fac 1277 1278 REAL(wp), PARAMETER :: rn_dif_ml = 0.8, rn_vis_ml = 0.375 1279 REAL(wp), PARAMETER :: rn_dif_pyc = 0.15, rn_vis_pyc = 0.142 1280 REAL(wp), PARAMETER :: rn_vispyc_shr = 0.15 1281 1282 DO_2D( 0, 0, 0, 0 ) 1283 IF ( lconv(ji,jj) ) THEN 1284 1285 zvel_sc_pyc = ( 0.15 * zvstr(ji,jj)**3 + zwstrc(ji,jj)**3 + 4.25 * zshear(ji,jj) * zhbl(ji,jj) )**pthird 1286 zvel_sc_ml = ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 1287 zstab_fac = ( zhml(ji,jj) / zvel_sc_ml * ( 1.4 - 0.4 / ( 1.0 + EXP(-3.5 * LOG10(-zhol(ji,jj) ) ) )**1.25 ) )**2 1288 1289 zdifml_sc(ji,jj) = rn_dif_ml * zhml(ji,jj) * zvel_sc_ml 1290 zvisml_sc(ji,jj) = rn_vis_ml * zdifml_sc(ji,jj) 1291 1292 IF ( lpyc(ji,jj) ) THEN 1293 zdifpyc_n_sc(ji,jj) = rn_dif_pyc * zvel_sc_ml * zdh(ji,jj) 1294 1295 IF ( lshear(ji,jj) .and. j_ddh(ji,jj) == 1 ) THEN 1296 zdifpyc_n_sc(ji,jj) = zdifpyc_n_sc(ji,jj) + rn_vispyc_shr * ( zshear(ji,jj) * zhbl(ji,jj) )**pthird * zhbl(ji,jj) 1297 ENDIF 1298 1299 zdifpyc_s_sc(ji,jj) = zwb_ent(ji,jj) + 0.0025 * zvel_sc_pyc * ( zhbl(ji,jj) / zdh(ji,jj) - 1.0 ) * ( zb_ml(ji,jj) - zb_bl(ji,jj) ) 1300 zdifpyc_s_sc(ji,jj) = 0.09 * zdifpyc_s_sc(ji,jj) * zstab_fac 1301 zdifpyc_s_sc(ji,jj) = MAX( zdifpyc_s_sc(ji,jj), -0.5 * zdifpyc_n_sc(ji,jj) ) 1302 1303 zvispyc_n_sc(ji,jj) = 0.09 * zvel_sc_pyc * ( 1.0 - zhbl(ji,jj) / zdh(ji,jj) )**2 * ( 0.005 * ( zu_ml(ji,jj)-zu_bl(ji,jj) )**2 + 0.0075 * ( zv_ml(ji,jj)-zv_bl(ji,jj) )**2 ) / zdh(ji,jj) 1304 zvispyc_n_sc(ji,jj) = rn_vis_pyc * zvel_sc_ml * zdh(ji,jj) + zvispyc_n_sc(ji,jj) * zstab_fac 1305 IF ( lshear(ji,jj) .and. j_ddh(ji,jj) == 1 ) THEN 1306 zvispyc_n_sc(ji,jj) = zvispyc_n_sc(ji,jj) + rn_vispyc_shr * ( zshear(ji,jj) * zhbl(ji,jj ) )**pthird * zhbl(ji,jj) 1307 ENDIF 1308 1309 zvispyc_s_sc(ji,jj) = 0.09 * ( zwb_min(ji,jj) + 0.0025 * zvel_sc_pyc * ( zhbl(ji,jj) / zdh(ji,jj) - 1.0 ) * ( zb_ml(ji,jj) - zb_bl(ji,jj) ) ) 1310 zvispyc_s_sc(ji,jj) = zvispyc_s_sc(ji,jj) * zstab_fac 1311 zvispyc_s_sc(ji,jj) = MAX( zvispyc_s_sc(ji,jj), -0.5 * zvispyc_s_sc(ji,jj) ) 1312 1313 zbeta_d_sc(ji,jj) = 1.0 - ( ( zdifpyc_n_sc(ji,jj) + 1.4 * zdifpyc_s_sc(ji,jj) ) / ( zdifml_sc(ji,jj) + epsln ) )**p2third 1314 zbeta_v_sc(ji,jj) = 1.0 - 2.0 * ( zvispyc_n_sc(ji,jj) + zvispyc_s_sc(ji,jj) ) / ( zvisml_sc(ji,jj) + epsln ) 1315 ELSE 1316 zbeta_d_sc(ji,jj) = 1.0 1317 zbeta_v_sc(ji,jj) = 1.0 1318 ENDIF 1319 ELSE 1320 zdifml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * MAX( EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ), 0.2_wp) 1321 zvisml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * MAX( EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ), 0.2_wp) 1322 END IF 1323 END_2D 1324 ! 1325 DO_2D( 0, 0, 0, 0 ) 1326 IF ( lconv(ji,jj) ) THEN 1327 DO jk = 2, imld(ji,jj) ! mixed layer diffusivity 1328 zznd_ml = gdepw(ji,jj,jk,Kmm) / zhml(ji,jj) 1329 ! 1330 zdiffut(ji,jj,jk) = zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_d_sc(ji,jj) * zznd_ml )**1.5 1331 ! 1332 zviscos(ji,jj,jk) = zvisml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_v_sc(ji,jj) * zznd_ml ) & 1333 & * ( 1.0 - 0.5 * zznd_ml**2 ) 1334 END DO 1335 ! pycnocline 1336 IF ( lpyc(ji,jj) ) THEN 1337 ! Diffusivity profile in the pycnocline given by cubic polynomial. 1338 za_cubic = 0.5 1339 zb_cubic = -1.75 * zdifpyc_s_sc(ji,jj) / zdifpyc_n_sc(ji,jj) 1340 zd_cubic = ( zdh(ji,jj) * zdifml_sc(ji,jj) / zhml(ji,jj) * SQRT( 1.0 - zbeta_d_sc(ji,jj) ) * ( 2.5 * zbeta_d_sc(ji,jj) - 1.0 ) & 1341 & - 0.85 * zdifpyc_s_sc(ji,jj) ) / MAX(zdifpyc_n_sc(ji,jj), 1.e-8) 1342 zd_cubic = zd_cubic - zb_cubic - 2.0 * ( 1.0 - za_cubic - zb_cubic ) 1343 zc_cubic = 1.0 - za_cubic - zb_cubic - zd_cubic 1344 DO jk = imld(ji,jj) , ibld(ji,jj) 1345 zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / MAX(zdh(ji,jj), 1.e-6) 1346 ! 1347 zdiffut(ji,jj,jk) = zdifpyc_n_sc(ji,jj) * ( za_cubic + zb_cubic * zznd_pyc + zc_cubic * zznd_pyc**2 + zd_cubic * zznd_pyc**3 ) 1348 1349 zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdifpyc_s_sc(ji,jj) * ( 1.75 * zznd_pyc - 0.15 * zznd_pyc**2 - 0.2 * zznd_pyc**3 ) 1350 END DO 1351 ! viscosity profiles. 1352 za_cubic = 0.5 1353 zb_cubic = -1.75 * zvispyc_s_sc(ji,jj) / zvispyc_n_sc(ji,jj) 1354 zd_cubic = ( 0.5 * zvisml_sc(ji,jj) * zdh(ji,jj) / zhml(ji,jj) - 0.85 * zvispyc_s_sc(ji,jj) ) / MAX(zvispyc_n_sc(ji,jj), 1.e-8) 1355 zd_cubic = zd_cubic - zb_cubic - 2.0 * ( 1.0 - za_cubic - zd_cubic ) 1356 zc_cubic = 1.0 - za_cubic - zb_cubic - zd_cubic 1357 DO jk = imld(ji,jj) , ibld(ji,jj) 1358 zznd_pyc = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / MAX(zdh(ji,jj), 1.e-6) 1359 zviscos(ji,jj,jk) = zvispyc_n_sc(ji,jj) * ( za_cubic + zb_cubic * zznd_pyc + zc_cubic * zznd_pyc**2 + zd_cubic * zznd_pyc**3 ) 1360 zviscos(ji,jj,jk) = zviscos(ji,jj,jk) + zvispyc_s_sc(ji,jj) * ( 1.75 * zznd_pyc - 0.15 * zznd_pyc**2 -0.2 * zznd_pyc**3 ) 1361 END DO 1362 IF ( zdhdt(ji,jj) > 0._wp ) THEN 1363 zdiffut(ji,jj,ibld(ji,jj)+1) = MAX( 0.5 * zdhdt(ji,jj) * e3w(ji,jj,ibld(ji,jj)+1,Kmm), 1.0e-6 ) 1364 zviscos(ji,jj,ibld(ji,jj)+1) = MAX( 0.5 * zdhdt(ji,jj) * e3w(ji,jj,ibld(ji,jj)+1,Kmm), 1.0e-6 ) 1365 ELSE 1366 zdiffut(ji,jj,ibld(ji,jj)) = 0._wp 1367 zviscos(ji,jj,ibld(ji,jj)) = 0._wp 1368 ENDIF 1369 ENDIF 1370 ELSE 1371 ! stable conditions 1372 DO jk = 2, ibld(ji,jj) 1373 zznd_ml = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 1374 zdiffut(ji,jj,jk) = 0.75 * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zznd_ml )**1.5 1375 zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * (1.0 - zznd_ml) * ( 1.0 - zznd_ml**2 ) 1376 END DO 1377 1378 IF ( zdhdt(ji,jj) > 0._wp ) THEN 1379 zdiffut(ji,jj,ibld(ji,jj)) = MAX(zdhdt(ji,jj), 1.0e-6) * e3w(ji, jj, ibld(ji,jj), Kmm) 1380 zviscos(ji,jj,ibld(ji,jj)) = MAX(zdhdt(ji,jj), 1.0e-6) * e3w(ji, jj, ibld(ji,jj), Kmm) 1381 ENDIF 1382 ENDIF ! end if ( lconv ) 1383 ! 1384 END_2D 1385 1386 END SUBROUTINE zdf_osm_diffusivity_viscosity 1387 1388 SUBROUTINE zdf_osm_osbl_state( lconv, lshear, j_ddh, zwb_ent, zwb_min, zshear, zri_i ) 1389 1390 !!--------------------------------------------------------------------- 1391 !! *** ROUTINE zdf_osm_osbl_state *** 1392 !! 1393 !! ** Purpose : Determines the state of the OSBL, stable/unstable, shear/ noshear. Also determines shear production, entrainment buoyancy flux and interfacial Richardson number 1394 !! 1395 !! ** Method : 1396 !! 1397 !! !!---------------------------------------------------------------------- 1398 1399 INTEGER, DIMENSION(jpi,jpj) :: j_ddh ! j_ddh = 0, active shear layer; j_ddh=1, shear layer not active; j_ddh=2 shear production low. 1400 1401 LOGICAL, DIMENSION(jpi,jpj) :: lconv, lshear 1402 1403 REAL(wp), DIMENSION(jpi,jpj) :: zwb_ent, zwb_min ! Buoyancy fluxes at base of well-mixed layer. 1404 REAL(wp), DIMENSION(jpi,jpj) :: zshear ! production of TKE due to shear across the pycnocline 1405 REAL(wp), DIMENSION(jpi,jpj) :: zri_i ! Interfacial Richardson Number 1406 1407 ! Local Variables 1408 1409 INTEGER :: jj, ji 1410 1411 REAL(wp), DIMENSION(jpi,jpj) :: zekman 1412 REAL(wp) :: zri_p, zri_b ! Richardson numbers 1413 REAL(wp) :: zshear_u, zshear_v, zwb_shr 1414 REAL(wp) :: zwcor, zrf_conv, zrf_shear, zrf_langmuir, zr_stokes 1415 1416 REAL, PARAMETER :: za_shr = 0.4, zb_shr = 6.5, za_wb_s = 0.1 1417 REAL, PARAMETER :: rn_ri_thres_a = 0.5, rn_ri_thresh_b = 0.59 1418 REAL, PARAMETER :: zalpha_c = 0.2, zalpha_lc = 0.04 1419 REAL, PARAMETER :: zalpha_ls = 0.06, zalpha_s = 0.15 1420 REAL, PARAMETER :: rn_ri_p_thresh = 27.0 1421 REAL, PARAMETER :: zrot=0._wp ! dummy rotation rate of surface stress. 1422 1423 ! Determins stability and set flag lconv 1424 DO_2D( 0, 0, 0, 0 ) 1425 IF ( zhol(ji,jj) < 0._wp ) THEN 1426 lconv(ji,jj) = .TRUE. 1427 ELSE 1428 lconv(ji,jj) = .FALSE. 1429 ENDIF 1430 END_2D 1431 1432 zekman(:,:) = EXP( - 4.0 * ABS( ff_t(:,:) ) * zhbl(:,:) / MAX(zustar(:,:), 1.e-8 ) ) 1433 1434 WHERE ( lconv ) 1435 zri_i = zdb_ml * zhml**2 / MAX( ( zvstr**3 + 0.5 * zwstrc**3 )**p2third * zdh, 1.e-12 ) 1436 END WHERE 1437 1438 zshear(:,:) = 0._wp 1439 j_ddh(:,:) = 1 1440 1441 DO_2D( 0, 0, 0, 0 ) 1442 IF ( lconv(ji,jj) ) THEN 1443 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 1444 zri_p = MAX ( SQRT( zdb_bl(ji,jj) * zdh(ji,jj) / MAX( zdu_bl(ji,jj)**2 + zdv_bl(ji,jj)**2, 1.e-8) ) * ( zhbl(ji,jj) / zdh(ji,jj) ) * ( zvstr(ji,jj) / MAX( zustar(ji,jj), 1.e-6 ) )**2 & 1445 & / MAX( zekman(ji,jj), 1.e-6 ) , 5._wp ) 1446 1447 zri_b = zdb_ml(ji,jj) * zdh(ji,jj) / MAX( zdu_ml(ji,jj)**2 + zdv_ml(ji,jj)**2, 1.e-8 ) 1448 1449 zshear(ji,jj) = za_shr * zekman(ji,jj) * ( MAX( zustar(ji,jj)**2 * zdu_ml(ji,jj) / zhbl(ji,jj), 0._wp ) + zb_shr * MAX( -ff_t(ji,jj) * zustke(ji,jj) * dstokes(ji,jj) * zdv_ml(ji,jj) / zhbl(ji,jj), 0._wp ) ) 1450 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1451 ! Test ensures j_ddh=0 is not selected. Change to zri_p<27 when ! 1452 ! full code available ! 1453 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1454 IF ( zri_p < -rn_ri_p_thresh .and. zshear(ji,jj) > 0._wp ) THEN 1455 ! Growing shear layer 1456 j_ddh(ji,jj) = 0 1457 lshear(ji,jj) = .TRUE. 1458 ELSE 1459 j_ddh(ji,jj) = 1 1460 IF ( zri_b <= 1.5 .and. zshear(ji,jj) > 0._wp ) THEN 1461 ! shear production large enough to determine layer charcteristics, but can't maintain a shear layer. 1462 lshear(ji,jj) = .TRUE. 1463 ELSE 1464 ! Shear production may not be zero, but is small and doesn't determine characteristics of pycnocline. 1465 zshear(ji,jj) = 0.5 * zshear(ji,jj) 1466 lshear(ji,jj) = .FALSE. 1467 ENDIF 1468 ENDIF 1469 ELSE ! zdb_bl test, note zshear set to zero 1470 j_ddh(ji,jj) = 2 1471 lshear(ji,jj) = .FALSE. 1472 ENDIF 1473 ENDIF 1474 END_2D 1475 1476 ! Calculate entrainment buoyancy flux due to surface fluxes. 1477 1478 DO_2D( 0, 0, 0, 0 ) 1479 IF ( lconv(ji,jj) ) THEN 1480 zwcor = ABS(ff_t(ji,jj)) * zhbl(ji,jj) + epsln 1481 zrf_conv = TANH( ( zwstrc(ji,jj) / zwcor )**0.69 ) 1482 zrf_shear = TANH( ( zustar(ji,jj) / zwcor )**0.69 ) 1483 zrf_langmuir = TANH( ( zwstrl(ji,jj) / zwcor )**0.69 ) 1484 IF (nn_osm_SD_reduce > 0 ) THEN 1485 ! Effective Stokes drift already reduced from surface value 1486 zr_stokes = 1.0_wp 1487 ELSE 1488 ! Effective Stokes drift only reduced by factor rn_zdfodm_adjust_sd, 1489 ! requires further reduction where BL is deep 1490 zr_stokes = 1.0 - EXP( -25.0 * dstokes(ji,jj) / hbl(ji,jj) & 1491 & * ( 1.0 + 4.0 * dstokes(ji,jj) / hbl(ji,jj) ) ) 1492 END IF 1493 zwb_ent(ji,jj) = - 2.0 * 0.2 * zrf_conv * zwbav(ji,jj) & 1494 & - 0.15 * zrf_shear * zustar(ji,jj)**3 /zhml(ji,jj) & 1495 & + zr_stokes * ( 0.15 * EXP( -1.5 * zla(ji,jj) ) * zrf_shear * zustar(ji,jj)**3 & 1496 & - zrf_langmuir * 0.03 * zwstrl(ji,jj)**3 ) / zhml(ji,jj) 1497 ! 1498 ENDIF 1499 END_2D 1500 1501 zwb_min(:,:) = 0._wp 1502 1503 DO_2D( 0, 0, 0, 0 ) 1504 IF ( lshear(ji,jj) ) THEN 1505 IF ( lconv(ji,jj) ) THEN 1506 ! Unstable OSBL 1507 zwb_shr = -za_wb_s * zshear(ji,jj) 1508 IF ( j_ddh(ji,jj) == 0 ) THEN 1509 1510 ! Developing shear layer, additional shear production possible. 1511 1512 zshear_u = MAX( zustar(ji,jj)**2 * zdu_ml(ji,jj) / zhbl(ji,jj), 0._wp ) 1513 zshear(ji,jj) = zshear(ji,jj) + zshear_u * ( 1.0 - MIN( zri_p / rn_ri_p_thresh, 1.d0 ) ) 1514 zshear(ji,jj) = MIN( zshear(ji,jj), zshear_u ) 1515 1516 zwb_shr = -za_wb_s * zshear(ji,jj) 1517 1518 ENDIF 1519 zwb_ent(ji,jj) = zwb_ent(ji,jj) + zwb_shr 1520 zwb_min(ji,jj) = zwb_ent(ji,jj) + zdh(ji,jj) / zhbl(ji,jj) * zwb0(ji,jj) 1521 ELSE ! IF ( lconv ) THEN - ENDIF 1522 ! Stable OSBL - shear production not coded for first attempt. 1523 ENDIF ! lconv 1524 ELSE ! lshear 1525 IF ( lconv(ji,jj) ) THEN 1526 ! Unstable OSBL 1527 zwb_shr = -za_wb_s * zshear(ji,jj) 1528 zwb_ent(ji,jj) = zwb_ent(ji,jj) + zwb_shr 1529 zwb_min(ji,jj) = zwb_ent(ji,jj) + zdh(ji,jj) / zhbl(ji,jj) * zwb0(ji,jj) 1530 ENDIF ! lconv 1531 ENDIF ! lshear 1532 END_2D 1533 END SUBROUTINE zdf_osm_osbl_state 1534 1535 1536 SUBROUTINE zdf_osm_vertical_average( jnlev_av, jp_ext, zt, zs, zb, zu, zv, zdt, zds, zdb, zdu, zdv ) 1537 !!--------------------------------------------------------------------- 1538 !! *** ROUTINE zdf_vertical_average *** 1539 !! 1540 !! ** Purpose : Determines vertical averages from surface to jnlev. 1541 !! 1542 !! ** Method : Averages are calculated from the surface to jnlev. 1543 !! The external level used to calculate differences is ibld+ibld_ext 1544 !! 1545 !!---------------------------------------------------------------------- 1546 1547 INTEGER, DIMENSION(jpi,jpj) :: jnlev_av ! Number of levels to average over. 1548 INTEGER, DIMENSION(jpi,jpj) :: jp_ext 1549 1550 ! Alan: do we need zb? 1551 REAL(wp), DIMENSION(jpi,jpj) :: zt, zs, zb ! Average temperature and salinity 1552 REAL(wp), DIMENSION(jpi,jpj) :: zu,zv ! Average current components 1553 REAL(wp), DIMENSION(jpi,jpj) :: zdt, zds, zdb ! Difference between average and value at base of OSBL 1554 REAL(wp), DIMENSION(jpi,jpj) :: zdu, zdv ! Difference for velocity components. 1555 1556 INTEGER :: jk, ji, jj, ibld_ext 1557 REAL(wp) :: zthick, zthermal, zbeta 1558 1559 1560 zt = 0._wp 1561 zs = 0._wp 1562 zu = 0._wp 1563 zv = 0._wp 1564 DO_2D( 0, 0, 0, 0 ) 1565 zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 1566 zbeta = rab_n(ji,jj,1,jp_sal) 1567 ! average over depth of boundary layer 1568 zthick = epsln 1569 DO jk = 2, jnlev_av(ji,jj) 1570 zthick = zthick + e3t(ji,jj,jk,Kmm) 1571 zt(ji,jj) = zt(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) 1572 zs(ji,jj) = zs(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 1573 zu(ji,jj) = zu(ji,jj) + e3t(ji,jj,jk,Kmm) & 1574 & * ( uu(ji,jj,jk,Kbb) + uu(ji - 1,jj,jk,Kbb) ) & 1575 & / MAX( 1. , umask(ji,jj,jk) + umask(ji - 1,jj,jk) ) 1576 zv(ji,jj) = zv(ji,jj) + e3t(ji,jj,jk,Kmm) & 1577 & * ( vv(ji,jj,jk,Kbb) + vv(ji,jj - 1,jk,Kbb) ) & 1578 & / MAX( 1. , vmask(ji,jj,jk) + vmask(ji,jj - 1,jk) ) 1579 END DO 1580 zt(ji,jj) = zt(ji,jj) / zthick 1581 zs(ji,jj) = zs(ji,jj) / zthick 1582 zu(ji,jj) = zu(ji,jj) / zthick 1583 zv(ji,jj) = zv(ji,jj) / zthick 1584 zb(ji,jj) = grav * zthermal * zt(ji,jj) - grav * zbeta * zs(ji,jj) 1585 ibld_ext = jnlev_av(ji,jj) + jp_ext(ji,jj) 1586 IF ( ibld_ext < mbkt(ji,jj) ) THEN 1587 zdt(ji,jj) = zt(ji,jj) - ts(ji,jj,ibld_ext,jp_tem,Kmm) 1588 zds(ji,jj) = zs(ji,jj) - ts(ji,jj,ibld_ext,jp_sal,Kmm) 1589 zdu(ji,jj) = zu(ji,jj) - ( uu(ji,jj,ibld_ext,Kbb) + uu(ji-1,jj,ibld_ext,Kbb ) ) & 1590 & / MAX(1. , umask(ji,jj,ibld_ext ) + umask(ji-1,jj,ibld_ext ) ) 1591 zdv(ji,jj) = zv(ji,jj) - ( vv(ji,jj,ibld_ext,Kbb) + vv(ji,jj-1,ibld_ext,Kbb ) ) & 1592 & / MAX(1. , vmask(ji,jj,ibld_ext ) + vmask(ji,jj-1,ibld_ext ) ) 1593 zdb(ji,jj) = grav * zthermal * zdt(ji,jj) - grav * zbeta * zds(ji,jj) 1594 ELSE 1595 zdt(ji,jj) = 0._wp 1596 zds(ji,jj) = 0._wp 1597 zdu(ji,jj) = 0._wp 1598 zdv(ji,jj) = 0._wp 1599 zdb(ji,jj) = 0._wp 1600 ENDIF 1601 END_2D 1602 END SUBROUTINE zdf_osm_vertical_average 1603 1604 SUBROUTINE zdf_osm_velocity_rotation( zcos_w, zsin_w, zu, zv, zdu, zdv ) 1605 !!--------------------------------------------------------------------- 1606 !! *** ROUTINE zdf_velocity_rotation *** 1607 !! 1608 !! ** Purpose : Rotates frame of reference of averaged velocity components. 1609 !! 1610 !! ** Method : The velocity components are rotated into frame specified by zcos_w and zsin_w 1611 !! 1612 !!---------------------------------------------------------------------- 1613 1614 REAL(wp), DIMENSION(jpi,jpj) :: zcos_w, zsin_w ! Cos and Sin of rotation angle 1615 REAL(wp), DIMENSION(jpi,jpj) :: zu, zv ! Components of current 1616 REAL(wp), DIMENSION(jpi,jpj) :: zdu, zdv ! Change in velocity components across pycnocline 1617 1618 INTEGER :: ji, jj 1619 REAL(wp) :: ztemp 1620 1621 DO_2D( 0, 0, 0, 0 ) 1622 ztemp = zu(ji,jj) 1623 zu(ji,jj) = zu(ji,jj) * zcos_w(ji,jj) + zv(ji,jj) * zsin_w(ji,jj) 1624 zv(ji,jj) = zv(ji,jj) * zcos_w(ji,jj) - ztemp * zsin_w(ji,jj) 1625 ztemp = zdu(ji,jj) 1626 zdu(ji,jj) = zdu(ji,jj) * zcos_w(ji,jj) + zdv(ji,jj) * zsin_w(ji,jj) 1627 zdv(ji,jj) = zdv(ji,jj) * zsin_w(ji,jj) - ztemp * zsin_w(ji,jj) 1628 END_2D 1629 END SUBROUTINE zdf_osm_velocity_rotation 1630 1631 SUBROUTINE zdf_osm_osbl_state_fk( lpyc, lflux, lmle, zwb_fk ) 1632 !!--------------------------------------------------------------------- 1633 !! *** ROUTINE zdf_osm_osbl_state_fk *** 1634 !! 1635 !! ** Purpose : Determines the state of the OSBL and MLE layer. Info is returned in the logicals lpyc,lflux and lmle. Used with Fox-Kemper scheme. 1636 !! lpyc :: determines whether pycnocline flux-grad relationship needs to be determined 1637 !! lflux :: determines whether effects of surface flux extend below the base of the OSBL 1638 !! lmle :: determines whether the layer with MLE is increasing with time or if base is relaxing towards hbl. 1639 !! 1640 !! ** Method : 1641 !! 1642 !! 1643 !!---------------------------------------------------------------------- 1644 1645 ! Outputs 1646 LOGICAL, DIMENSION(jpi,jpj) :: lpyc, lflux, lmle 1647 REAL(wp), DIMENSION(jpi,jpj) :: zwb_fk 1648 ! 1649 REAL(wp), DIMENSION(jpi,jpj) :: znd_param 1650 REAL(wp) :: zbuoy, ztmp, zpe_mle_layer 1651 REAL(wp) :: zpe_mle_ref, zwb_ent, zdbdz_mle_int 1652 1653 znd_param(:,:) = 0._wp 1654 1655 DO_2D( 0, 0, 0, 0 ) 1656 ztmp = r1_ft(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) / rn_osm_mle_lf 1657 zwb_fk(ji,jj) = rn_osm_mle_ce * hmle(ji,jj) * hmle(ji,jj) * ztmp * zdbds_mle(ji,jj) * zdbds_mle(ji,jj) 1658 END_2D 1659 DO_2D( 0, 0, 0, 0 ) 1660 ! 1661 IF ( lconv(ji,jj) ) THEN 1662 IF ( zhmle(ji,jj) > 1.2 * zhbl(ji,jj) ) THEN 1663 zt_mle(ji,jj) = ( zt_mle(ji,jj) * zhmle(ji,jj) - zt_bl(ji,jj) * zhbl(ji,jj) ) / ( zhmle(ji,jj) - zhbl(ji,jj) ) 1664 zs_mle(ji,jj) = ( zs_mle(ji,jj) * zhmle(ji,jj) - zs_bl(ji,jj) * zhbl(ji,jj) ) / ( zhmle(ji,jj) - zhbl(ji,jj) ) 1665 zb_mle(ji,jj) = ( zb_mle(ji,jj) * zhmle(ji,jj) - zb_bl(ji,jj) * zhbl(ji,jj) ) / ( zhmle(ji,jj) - zhbl(ji,jj) ) 1666 zdbdz_mle_int = ( zb_bl(ji,jj) - ( 2.0 * zb_mle(ji,jj) -zb_bl(ji,jj) ) ) / ( zhmle(ji,jj) - zhbl(ji,jj) ) 1667 ! Calculate potential energies of actual profile and reference profile. 1668 zpe_mle_layer = 0._wp 1669 zpe_mle_ref = 0._wp 1670 DO jk = ibld(ji,jj), mld_prof(ji,jj) 1671 zbuoy = grav * ( zthermal * ts(ji,jj,jk,jp_tem,Kmm) - zbeta * ts(ji,jj,jk,jp_sal,Kmm) ) 1672 zpe_mle_layer = zpe_mle_layer + zbuoy * gdepw(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 1673 zpe_mle_ref = zpe_mle_ref + ( zb_bl(ji,jj) - zdbdz_mle_int * ( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) ) * gdepw(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 1674 END DO 1675 ! Non-dimensional parameter to diagnose the presence of thermocline 1676 1677 znd_param(ji,jj) = ( zpe_mle_layer - zpe_mle_ref ) * ABS( ff_t(ji,jj) ) / ( MAX( zwb_fk(ji,jj), 1.0e-10 ) * zhmle(ji,jj) ) 1678 ENDIF 1679 ENDIF 1680 END_2D 1681 1682 ! Diagnosis 1683 DO_2D( 0, 0, 0, 0 ) 1684 IF ( lconv(ji,jj) ) THEN 1685 zwb_ent = - 2.0 * 0.2 * zwbav(ji,jj) & 1686 & - 0.15 * zustar(ji,jj)**3 /zhml(ji,jj) & 1687 & + ( 0.15 * EXP( -1.5 * zla(ji,jj) ) * zustar(ji,jj)**3 & 1688 & - 0.03 * zwstrl(ji,jj)**3 ) / zhml(ji,jj) 1689 IF ( -2.0 * zwb_fk(ji,jj) / zwb_ent > 0.5 ) THEN 1690 IF ( zhmle(ji,jj) > 1.2 * zhbl(ji,jj) ) THEN 1691 ! MLE layer growing 1692 IF ( znd_param (ji,jj) > 100. ) THEN 1693 ! Thermocline present 1694 lflux(ji,jj) = .FALSE. 1695 lmle(ji,jj) =.FALSE. 1696 ELSE 1697 ! Thermocline not present 1698 lflux(ji,jj) = .TRUE. 1699 lmle(ji,jj) = .TRUE. 1700 ENDIF ! znd_param > 100 1701 ! 1702 IF ( zdb_bl(ji,jj) < rn_osm_bl_thresh ) THEN 1703 lpyc(ji,jj) = .FALSE. 1704 ELSE 1705 lpyc = .TRUE. 1706 ENDIF 1707 ELSE 1708 ! MLE layer restricted to OSBL or just below. 1709 IF ( zdb_bl(ji,jj) < rn_osm_bl_thresh ) THEN 1710 ! Weak stratification MLE layer can grow. 1711 lpyc(ji,jj) = .FALSE. 1712 lflux(ji,jj) = .TRUE. 1713 lmle(ji,jj) = .TRUE. 1714 ELSE 1715 ! Strong stratification 1716 lpyc(ji,jj) = .TRUE. 1717 lflux(ji,jj) = .FALSE. 1718 lmle(ji,jj) = .FALSE. 1719 ENDIF ! zdb_bl < rn_mle_thresh_bl and 1720 ENDIF ! zhmle > 1.2 zhbl 1721 ELSE 1722 lpyc(ji,jj) = .TRUE. 1723 lflux(ji,jj) = .FALSE. 1724 lmle(ji,jj) = .FALSE. 1725 IF ( zdb_bl(ji,jj) < rn_osm_bl_thresh ) lpyc(ji,jj) = .FALSE. 1726 ENDIF ! -2.0 * zwb_fk(ji,jj) / zwb_ent > 0.5 1727 ELSE 1728 ! Stable Boundary Layer 1729 lpyc(ji,jj) = .FALSE. 1730 lflux(ji,jj) = .FALSE. 1731 lmle(ji,jj) = .FALSE. 1732 ENDIF ! lconv 1733 END_2D 1734 END SUBROUTINE zdf_osm_osbl_state_fk 1735 1736 SUBROUTINE zdf_osm_external_gradients(jbase, zdtdz, zdsdz, zdbdz ) 1737 !!--------------------------------------------------------------------- 1738 !! *** ROUTINE zdf_osm_external_gradients *** 1739 !! 1740 !! ** Purpose : Calculates the gradients below the OSBL 1741 !! 1742 !! ** Method : Uses ibld and ibld_ext to determine levels to calculate the gradient. 1743 !! 1744 !!---------------------------------------------------------------------- 1745 1746 INTEGER, DIMENSION(jpi,jpj) :: jbase 1747 REAL(wp), DIMENSION(jpi,jpj) :: zdtdz, zdsdz, zdbdz ! External gradients of temperature, salinity and buoyancy. 1748 1749 INTEGER :: jj, ji, jkb, jkb1 1750 REAL(wp) :: zthermal, zbeta 1751 1752 1753 DO_2D( 0, 0, 0, 0 ) 1754 IF ( jbase(ji,jj)+1 < mbkt(ji,jj) ) THEN 1755 zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? 1756 zbeta = rab_n(ji,jj,1,jp_sal) 1757 jkb = jbase(ji,jj) 1758 jkb1 = MIN(jkb + 1, mbkt(ji,jj)) 1759 zdtdz(ji,jj) = - ( ts(ji,jj,jkb1,jp_tem,Kmm) - ts(ji,jj,jkb,jp_tem,Kmm ) ) & 1760 & / e3t(ji,jj,ibld(ji,jj),Kmm) 1761 zdsdz(ji,jj) = - ( ts(ji,jj,jkb1,jp_sal,Kmm) - ts(ji,jj,jkb,jp_sal,Kmm ) ) & 1762 & / e3t(ji,jj,ibld(ji,jj),Kmm) 1763 zdbdz(ji,jj) = grav * zthermal * zdtdz(ji,jj) - grav * zbeta * zdsdz(ji,jj) 1764 ELSE 1765 zdtdz(ji,jj) = 0._wp 1766 zdsdz(ji,jj) = 0._wp 1767 zdbdz(ji,jj) = 0._wp 1768 END IF 1769 END_2D 1770 END SUBROUTINE zdf_osm_external_gradients 1771 1772 SUBROUTINE zdf_osm_pycnocline_scalar_profiles( zdtdz, zdsdz, zdbdz, zalpha ) 1773 1774 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdtdz, zdsdz, zdbdz ! gradients in the pycnocline 1775 REAL(wp), DIMENSION(jpi,jpj) :: zalpha 1776 1777 INTEGER :: jk, jj, ji 1778 REAL(wp) :: ztgrad, zsgrad, zbgrad 1779 REAL(wp) :: zgamma_b_nd, znd 1780 REAL(wp) :: zzeta_m, zzeta_en, zbuoy_pyc_sc 1781 REAL(wp), PARAMETER :: zgamma_b = 2.25, zzeta_sh = 0.15 1782 1783 DO_2D( 0, 0, 0, 0 ) 1784 IF ( ibld(ji,jj) + jp_ext(ji,jj) < mbkt(ji,jj) ) THEN 1785 IF ( lconv(ji,jj) ) THEN ! convective conditions 1786 IF ( lpyc(ji,jj) ) THEN 1787 zzeta_m = 0.1 + 0.3 / ( 1.0 + EXP( -3.5 * LOG10( -zhol(ji,jj) ) ) ) 1788 zalpha(ji,jj) = 2.0 * ( 1.0 - ( 0.80 * zzeta_m + 0.5 * SQRT( 3.14159 / zgamma_b ) ) * zdbdz_bl_ext(ji,jj) * zdh(ji,jj) / zdb_ml(ji,jj) ) / ( 0.723 + SQRT( 3.14159 / zgamma_b ) ) 1789 zalpha(ji,jj) = MAX( zalpha(ji,jj), 0._wp ) 1790 1791 ztmp = 1._wp/MAX(zdh(ji,jj), epsln) 1792 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1793 ! Commented lines in this section are not needed in new code, once tested ! 1794 ! can be removed ! 1795 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1796 ! ztgrad = zalpha * zdt_ml(ji,jj) * ztmp + zdtdz_bl_ext(ji,jj) 1797 ! zsgrad = zalpha * zds_ml(ji,jj) * ztmp + zdsdz_bl_ext(ji,jj) 1798 zbgrad = zalpha(ji,jj) * zdb_ml(ji,jj) * ztmp + zdbdz_bl_ext(ji,jj) 1799 zgamma_b_nd = zdbdz_bl_ext(ji,jj) * zdh(ji,jj) / MAX(zdb_ml(ji,jj), epsln) 1800 DO jk = 2, ibld(ji,jj)+ibld_ext 1801 znd = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) * ztmp 1802 IF ( znd <= zzeta_m ) THEN 1803 ! zdtdz(ji,jj,jk) = zdtdz_bl_ext(ji,jj) + zalpha * zdt_ml(ji,jj) * ztmp * & 1804 ! & EXP( -6.0 * ( znd -zzeta_m )**2 ) 1805 ! zdsdz(ji,jj,jk) = zdsdz_bl_ext(ji,jj) + zalpha * zds_ml(ji,jj) * ztmp * & 1806 ! & EXP( -6.0 * ( znd -zzeta_m )**2 ) 1807 zdbdz(ji,jj,jk) = zdbdz_bl_ext(ji,jj) + zalpha(ji,jj) * zdb_ml(ji,jj) * ztmp * & 1808 & EXP( -6.0 * ( znd -zzeta_m )**2 ) 1809 ELSE 1810 ! zdtdz(ji,jj,jk) = ztgrad * EXP( -zgamma_b * ( znd - zzeta_m )**2 ) 1811 ! zdsdz(ji,jj,jk) = zsgrad * EXP( -zgamma_b * ( znd - zzeta_m )**2 ) 1812 zdbdz(ji,jj,jk) = zbgrad * EXP( -zgamma_b * ( znd - zzeta_m )**2 ) 1813 ENDIF 1814 END DO 1815 ENDIF ! if no pycnocline pycnocline gradients set to zero 1816 ELSE 1817 ! stable conditions 1818 ! if pycnocline profile only defined when depth steady of increasing. 1819 IF ( zdhdt(ji,jj) > 0.0 ) THEN ! Depth increasing, or steady. 1820 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 1821 IF ( zhol(ji,jj) >= 0.5 ) THEN ! Very stable - 'thick' pycnocline 1822 ztmp = 1._wp/MAX(zhbl(ji,jj), epsln) 1823 ztgrad = zdt_bl(ji,jj) * ztmp 1824 zsgrad = zds_bl(ji,jj) * ztmp 1825 zbgrad = zdb_bl(ji,jj) * ztmp 1826 DO jk = 2, ibld(ji,jj) 1827 znd = gdepw(ji,jj,jk,Kmm) * ztmp 1828 zdtdz(ji,jj,jk) = ztgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 1829 zdbdz(ji,jj,jk) = zbgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 1830 zdsdz(ji,jj,jk) = zsgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) 1831 END DO 1832 ELSE ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form. 1833 ztmp = 1._wp/MAX(zdh(ji,jj), epsln) 1834 ztgrad = zdt_bl(ji,jj) * ztmp 1835 zsgrad = zds_bl(ji,jj) * ztmp 1836 zbgrad = zdb_bl(ji,jj) * ztmp 1837 DO jk = 2, ibld(ji,jj) 1838 znd = -( gdepw(ji,jj,jk,Kmm) - zhml(ji,jj) ) * ztmp 1839 zdtdz(ji,jj,jk) = ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 1840 zdbdz(ji,jj,jk) = zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 1841 zdsdz(ji,jj,jk) = zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) 1842 END DO 1843 ENDIF ! IF (zhol >=0.5) 1844 ENDIF ! IF (zdb_bl> 0.) 1845 ENDIF ! IF (zdhdt >= 0) zdhdt < 0 not considered since pycnocline profile is zero and profile arrays are intialized to zero 1846 ENDIF ! IF (lconv) 1847 ENDIF ! IF ( ibld(ji,jj) < mbkt(ji,jj) ) 1848 END_2D 1849 1850 END SUBROUTINE zdf_osm_pycnocline_scalar_profiles 1851 1852 SUBROUTINE zdf_osm_pycnocline_shear_profiles( zdudz, zdvdz ) 1853 !!--------------------------------------------------------------------- 1854 !! *** ROUTINE zdf_osm_pycnocline_shear_profiles *** 1855 !! 1856 !! ** Purpose : Calculates velocity shear in the pycnocline 1857 !! 1858 !! ** Method : 1859 !! 1860 !!---------------------------------------------------------------------- 1861 1862 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdudz, zdvdz 1863 1864 INTEGER :: jk, jj, ji 1865 REAL(wp) :: zugrad, zvgrad, znd 1866 REAL(wp) :: zzeta_v = 0.45 1290 1867 ! 1291 END SUBROUTINE zdf_osm 1292 1293 1294 SUBROUTINE zdf_osm_init( Kmm ) 1868 DO_2D( 0, 0, 0, 0 ) 1869 ! 1870 IF ( ibld(ji,jj) + jp_ext(ji,jj) < mbkt(ji,jj) ) THEN 1871 IF ( lconv (ji,jj) ) THEN 1872 ! Unstable conditions. Shouldn;t be needed with no pycnocline code. 1873 ! zugrad = 0.7 * zdu_ml(ji,jj) / zdh(ji,jj) + 0.3 * zustar(ji,jj)*zustar(ji,jj) / & 1874 ! & ( ( ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zhml(ji,jj) ) * & 1875 ! & MIN(zla(ji,jj)**(8.0/3.0) + epsln, 0.12 )) 1876 !Alan is this right? 1877 ! zvgrad = ( 0.7 * zdv_ml(ji,jj) + & 1878 ! & 2.0 * ff_t(ji,jj) * zustke(ji,jj) * dstokes(ji,jj) / & 1879 ! & ( ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird + epsln ) & 1880 ! & )/ (zdh(ji,jj) + epsln ) 1881 ! DO jk = 2, ibld(ji,jj) - 1 + ibld_ext 1882 ! znd = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / (zdh(ji,jj) + epsln ) - zzeta_v 1883 ! IF ( znd <= 0.0 ) THEN 1884 ! zdudz(ji,jj,jk) = 1.25 * zugrad * EXP( 3.0 * znd ) 1885 ! zdvdz(ji,jj,jk) = 1.25 * zvgrad * EXP( 3.0 * znd ) 1886 ! ELSE 1887 ! zdudz(ji,jj,jk) = 1.25 * zugrad * EXP( -2.0 * znd ) 1888 ! zdvdz(ji,jj,jk) = 1.25 * zvgrad * EXP( -2.0 * znd ) 1889 ! ENDIF 1890 ! END DO 1891 ELSE 1892 ! stable conditions 1893 zugrad = 3.25 * zdu_bl(ji,jj) / zhbl(ji,jj) 1894 zvgrad = 2.75 * zdv_bl(ji,jj) / zhbl(ji,jj) 1895 DO jk = 2, ibld(ji,jj) 1896 znd = gdepw(ji,jj,jk,Kmm) / zhbl(ji,jj) 1897 IF ( znd < 1.0 ) THEN 1898 zdudz(ji,jj,jk) = zugrad * EXP( -40.0 * ( znd - 1.0 )**2 ) 1899 ELSE 1900 zdudz(ji,jj,jk) = zugrad * EXP( -20.0 * ( znd - 1.0 )**2 ) 1901 ENDIF 1902 zdvdz(ji,jj,jk) = zvgrad * EXP( -20.0 * ( znd - 0.85 )**2 ) 1903 END DO 1904 ENDIF 1905 ! 1906 END IF ! IF ( ibld(ji,jj) + ibld_ext < mbkt(ji,jj) ) 1907 END_2D 1908 END SUBROUTINE zdf_osm_pycnocline_shear_profiles 1909 1910 SUBROUTINE zdf_osm_calculate_dhdt( zdhdt, zddhdt ) 1911 !!--------------------------------------------------------------------- 1912 !! *** ROUTINE zdf_osm_calculate_dhdt *** 1913 !! 1914 !! ** Purpose : Calculates the rate at which hbl changes. 1915 !! 1916 !! ** Method : 1917 !! 1918 !!---------------------------------------------------------------------- 1919 1920 REAL(wp), DIMENSION(jpi,jpj) :: zdhdt, zddhdt ! Rate of change of hbl 1921 1922 INTEGER :: jj, ji 1923 REAL(wp) :: zgamma_b_nd, zgamma_dh_nd, zpert, zpsi 1924 REAL(wp) :: zvel_max!, zwb_min 1925 REAL(wp) :: zzeta_m = 0.3 1926 REAL(wp) :: zgamma_c = 2.0 1927 REAL(wp) :: zdhoh = 0.1 1928 REAL(wp) :: alpha_bc = 0.5 1929 REAL, PARAMETER :: a_ddh = 2.5, a_ddh_2 = 3.5 ! also in pycnocline_depth 1930 1931 DO_2D( 0, 0, 0, 0 ) 1932 1933 IF ( lshear(ji,jj) ) THEN 1934 IF ( lconv(ji,jj) ) THEN ! Convective 1935 1936 IF ( ln_osm_mle ) THEN 1937 1938 IF ( hmle(ji,jj) > hbl(ji,jj) ) THEN 1939 ! Fox-Kemper buoyancy flux average over OSBL 1940 zwb_fk_b(ji,jj) = zwb_fk(ji,jj) * & 1941 (1.0 + hmle(ji,jj) / ( 6.0 * hbl(ji,jj) ) * (-1.0 + ( 1.0 - 2.0 * hbl(ji,jj) / hmle(ji,jj))**3) ) 1942 ELSE 1943 zwb_fk_b(ji,jj) = 0.5 * zwb_fk(ji,jj) * hmle(ji,jj) / hbl(ji,jj) 1944 ENDIF 1945 zvel_max = ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**p2third / hbl(ji,jj) 1946 IF ( ( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) < 0.0 ) THEN 1947 ! OSBL is deepening, entrainment > restratification 1948 IF ( zdb_bl(ji,jj) > 0.0 .and. zdbdz_bl_ext(ji,jj) > 0.0 ) THEN 1949 ! *** Used for shear Needs to be changed to work stabily 1950 ! zgamma_b_nd = zdbdz_bl_ext * dh / zdb_ml 1951 ! zalpha_b = 6.7 * zgamma_b_nd / ( 1.0 + zgamma_b_nd ) 1952 ! zgamma_b = zgamma_b_nd / ( 0.12 * ( 1.25 + zgamma_b_nd ) ) 1953 ! za_1 = 1.0 / zgamma_b**2 - 0.017 1954 ! za_2 = 1.0 / zgamma_b**3 - 0.0025 1955 ! zpsi = zalpha_b * ( 1.0 + zgamma_b_nd ) * ( za_1 - 2.0 * za_2 * dh / hbl ) 1956 zpsi = 0._wp 1957 zdhdt(ji,jj) = -( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) / ( zvel_max + MAX(zdb_bl(ji,jj), 1.0e-15) ) 1958 zdhdt(ji,jj) = zdhdt(ji,jj)! - zpsi * ( -1.0 / zhml(ji,jj) + 2.4 * zdbdz_bl_ext(ji,jj) / zdb_ml(ji,jj) ) * zwb_min(ji,jj) * zdh(ji,jj) / zdb_bl(ji,jj) 1959 IF ( j_ddh(ji,jj) == 1 ) THEN 1960 IF ( ( zwstrc(ji,jj) / zvstr(ji,jj) )**3 <= 0.5 ) THEN 1961 zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zvstr(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 1962 ELSE 1963 zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zwstrc(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 1964 ENDIF 1965 ! Relaxation to dh_ref = zari * hbl 1966 zddhdt(ji,jj) = -a_ddh_2 * ( 1.0 - zdh(ji,jj) / ( zari * zhbl(ji,jj) ) ) * zwb_ent(ji,jj) / zdb_bl(ji,jj) 1967 1968 ELSE ! j_ddh == 0 1969 ! Growing shear layer 1970 zddhdt(ji,jj) = -a_ddh * ( 1.0 - zdh(ji,jj) / zhbl(ji,jj) ) * zwb_ent(ji,jj) / zdb_bl(ji,jj) 1971 ENDIF ! j_ddh 1972 zdhdt(ji,jj) = zdhdt(ji,jj) ! + zpsi * zddhdt(ji,jj) 1973 ELSE ! zdb_bl >0 1974 zdhdt(ji,jj) = -( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) / MAX( zvel_max, 1.0e-15) 1975 ENDIF 1976 ELSE ! zwb_min + 2*zwb_fk_b < 0 1977 ! OSBL shoaling due to restratification flux. This is the velocity defined in Fox-Kemper et al (2008) 1978 zdhdt(ji,jj) = - zvel_mle(ji,jj) 1979 1980 1981 ENDIF 1982 1983 ELSE 1984 ! Fox-Kemper not used. 1985 1986 zvel_max = - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / hbl(ji,jj) ) * zwb_ent(ji,jj) / & 1987 & MAX((zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird, epsln) 1988 zdhdt(ji,jj) = -zwb_ent(ji,jj) / ( zvel_max + MAX(zdb_bl(ji,jj), 1.0e-15) ) 1989 ! added ajgn 23 July as temporay fix 1990 1991 ENDIF ! ln_osm_mle 1992 1993 ELSE ! lconv - Stable 1994 zdhdt(ji,jj) = ( 0.06 + 0.52 * zhol(ji,jj) / 2.0 ) * zvstr(ji,jj)**3 / hbl(ji,jj) + zwbav(ji,jj) 1995 IF ( zdhdt(ji,jj) < 0._wp ) THEN 1996 ! For long timsteps factor in brackets slows the rapid collapse of the OSBL 1997 zpert = 2.0 * ( 1.0 + 0.0 * 2.0 * zvstr(ji,jj) * rn_Dt / hbl(ji,jj) ) * zvstr(ji,jj)**2 / hbl(ji,jj) 1998 ELSE 1999 zpert = MAX( 2.0 * zvstr(ji,jj)**2 / hbl(ji,jj), zdb_bl(ji,jj) ) 2000 ENDIF 2001 zdhdt(ji,jj) = 2.0 * zdhdt(ji,jj) / MAX(zpert, epsln) 2002 ENDIF ! lconv 2003 ELSE ! lshear 2004 IF ( lconv(ji,jj) ) THEN ! Convective 2005 2006 IF ( ln_osm_mle ) THEN 2007 2008 IF ( hmle(ji,jj) > hbl(ji,jj) ) THEN 2009 ! Fox-Kemper buoyancy flux average over OSBL 2010 zwb_fk_b(ji,jj) = zwb_fk(ji,jj) * & 2011 (1.0 + hmle(ji,jj) / ( 6.0 * hbl(ji,jj) ) * (-1.0 + ( 1.0 - 2.0 * hbl(ji,jj) / hmle(ji,jj))**3) ) 2012 ELSE 2013 zwb_fk_b(ji,jj) = 0.5 * zwb_fk(ji,jj) * hmle(ji,jj) / hbl(ji,jj) 2014 ENDIF 2015 zvel_max = ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**p2third / hbl(ji,jj) 2016 IF ( ( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) < 0.0 ) THEN 2017 ! OSBL is deepening, entrainment > restratification 2018 IF ( zdb_bl(ji,jj) > 0.0 .and. zdbdz_bl_ext(ji,jj) > 0.0 ) THEN 2019 zdhdt(ji,jj) = -( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) / ( zvel_max + MAX(zdb_bl(ji,jj), 1.0e-15) ) 2020 ELSE 2021 zdhdt(ji,jj) = -( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) / MAX( zvel_max, 1.0e-15) 2022 ENDIF 2023 ELSE 2024 ! OSBL shoaling due to restratification flux. This is the velocity defined in Fox-Kemper et al (2008) 2025 zdhdt(ji,jj) = - zvel_mle(ji,jj) 2026 2027 2028 ENDIF 2029 2030 ELSE 2031 ! Fox-Kemper not used. 2032 2033 zvel_max = -zwb_ent(ji,jj) / & 2034 & MAX((zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird, epsln) 2035 zdhdt(ji,jj) = -zwb_ent(ji,jj) / ( zvel_max + MAX(zdb_bl(ji,jj), 1.0e-15) ) 2036 ! added ajgn 23 July as temporay fix 2037 2038 ENDIF ! ln_osm_mle 2039 2040 ELSE ! Stable 2041 zdhdt(ji,jj) = ( 0.06 + 0.52 * zhol(ji,jj) / 2.0 ) * zvstr(ji,jj)**3 / hbl(ji,jj) + zwbav(ji,jj) 2042 IF ( zdhdt(ji,jj) < 0._wp ) THEN 2043 ! For long timsteps factor in brackets slows the rapid collapse of the OSBL 2044 zpert = 2.0 * zvstr(ji,jj)**2 / hbl(ji,jj) 2045 ELSE 2046 zpert = MAX( 2.0 * zvstr(ji,jj)**2 / hbl(ji,jj), zdb_bl(ji,jj) ) 2047 ENDIF 2048 zdhdt(ji,jj) = 2.0 * zdhdt(ji,jj) / MAX(zpert, epsln) 2049 ENDIF ! lconv 2050 ENDIF ! lshear 2051 END_2D 2052 END SUBROUTINE zdf_osm_calculate_dhdt 2053 2054 SUBROUTINE zdf_osm_timestep_hbl( zdhdt ) 2055 !!--------------------------------------------------------------------- 2056 !! *** ROUTINE zdf_osm_timestep_hbl *** 2057 !! 2058 !! ** Purpose : Increments hbl. 2059 !! 2060 !! ** Method : If thechange in hbl exceeds one model level the change is 2061 !! is calculated by moving down the grid, changing the buoyancy 2062 !! jump. This is to ensure that the change in hbl does not 2063 !! overshoot a stable layer. 2064 !! 2065 !!---------------------------------------------------------------------- 2066 2067 2068 REAL(wp), DIMENSION(jpi,jpj) :: zdhdt ! rates of change of hbl. 2069 2070 INTEGER :: jk, jj, ji, jm 2071 REAL(wp) :: zhbl_s, zvel_max, zdb 2072 REAL(wp) :: zthermal, zbeta 2073 2074 DO_2D( 0, 0, 0, 0 ) 2075 IF ( ibld(ji,jj) - imld(ji,jj) > 1 ) THEN 2076 ! 2077 ! If boundary layer changes by more than one level, need to check for stable layers between initial and final depths. 2078 ! 2079 zhbl_s = hbl(ji,jj) 2080 jm = imld(ji,jj) 2081 zthermal = rab_n(ji,jj,1,jp_tem) 2082 zbeta = rab_n(ji,jj,1,jp_sal) 2083 2084 2085 IF ( lconv(ji,jj) ) THEN 2086 !unstable 2087 2088 IF( ln_osm_mle ) THEN 2089 zvel_max = ( zwstrl(ji,jj)**3 + zwstrc(ji,jj)**3 )**p2third / hbl(ji,jj) 2090 ELSE 2091 2092 zvel_max = -( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_Dt / hbl(ji,jj) ) * zwb_ent(ji,jj) / & 2093 & ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird 2094 2095 ENDIF 2096 2097 DO jk = imld(ji,jj), ibld(ji,jj) 2098 zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) ) & 2099 & - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), & 2100 & 0.0 ) + zvel_max 2101 2102 2103 IF ( ln_osm_mle ) THEN 2104 zhbl_s = zhbl_s + MIN( & 2105 & rn_Dt * ( ( -zwb_ent(ji,jj) - 2.0 * zwb_fk_b(ji,jj) )/ zdb ) / FLOAT(ibld(ji,jj) - imld(ji,jj) ), & 2106 & e3w(ji,jj,jm,Kmm) ) 2107 ELSE 2108 zhbl_s = zhbl_s + MIN( & 2109 & rn_Dt * ( -zwb_ent(ji,jj) / zdb ) / FLOAT(ibld(ji,jj) - imld(ji,jj) ), & 2110 & e3w(ji,jj,jm,Kmm) ) 2111 ENDIF 2112 2113 ! zhbl_s = MIN(zhbl_s, gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) 2114 IF ( zhbl_s >= gdepw(ji,jj,mbkt(ji,jj) + 1,Kmm) ) THEN 2115 zhbl_s = MIN(zhbl_s, gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) 2116 lpyc(ji,jj) = .FALSE. 2117 ENDIF 2118 IF ( zhbl_s >= gdepw(ji,jj,jm+1,Kmm) ) jm = jm + 1 2119 END DO 2120 hbl(ji,jj) = zhbl_s 2121 ibld(ji,jj) = jm 2122 ELSE 2123 ! stable 2124 DO jk = imld(ji,jj), ibld(ji,jj) 2125 zdb = MAX( & 2126 & grav * ( zthermal * ( zt_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) )& 2127 & - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ),& 2128 & 0.0 ) + & 2129 & 2.0 * zvstr(ji,jj)**2 / zhbl_s 2130 2131 ! Alan is thuis right? I have simply changed hbli to hbl 2132 zhol(ji,jj) = -zhbl_s / ( ( zvstr(ji,jj)**3 + epsln )/ zwbav(ji,jj) ) 2133 zdhdt(ji,jj) = -( zwbav(ji,jj) - 0.04 / 2.0 * zwstrl(ji,jj)**3 / zhbl_s - 0.15 / 2.0 * ( 1.0 - EXP( -1.5 * zla(ji,jj) ) ) * & 2134 & zustar(ji,jj)**3 / zhbl_s ) * ( 0.725 + 0.225 * EXP( -7.5 * zhol(ji,jj) ) ) 2135 zdhdt(ji,jj) = zdhdt(ji,jj) + zwbav(ji,jj) 2136 zhbl_s = zhbl_s + MIN( zdhdt(ji,jj) / zdb * rn_Dt / FLOAT( ibld(ji,jj) - imld(ji,jj) ), e3w(ji,jj,jm,Kmm) ) 2137 2138 ! zhbl_s = MIN(zhbl_s, gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) 2139 IF ( zhbl_s >= mbkt(ji,jj) + 1 ) THEN 2140 zhbl_s = MIN(zhbl_s, gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) 2141 lpyc(ji,jj) = .FALSE. 2142 ENDIF 2143 IF ( zhbl_s >= gdepw(ji,jj,jm,Kmm) ) jm = jm + 1 2144 END DO 2145 ENDIF ! IF ( lconv ) 2146 hbl(ji,jj) = MAX(zhbl_s, gdepw(ji,jj,4,Kmm) ) 2147 ibld(ji,jj) = MAX(jm, 4 ) 2148 ELSE 2149 ! change zero or one model level. 2150 hbl(ji,jj) = MAX(zhbl_t(ji,jj), gdepw(ji,jj,4,Kmm) ) 2151 ENDIF 2152 zhbl(ji,jj) = gdepw(ji,jj,ibld(ji,jj),Kmm) 2153 END_2D 2154 2155 END SUBROUTINE zdf_osm_timestep_hbl 2156 2157 SUBROUTINE zdf_osm_pycnocline_thickness( dh, zdh ) 2158 !!--------------------------------------------------------------------- 2159 !! *** ROUTINE zdf_osm_pycnocline_thickness *** 2160 !! 2161 !! ** Purpose : Calculates thickness of the pycnocline 2162 !! 2163 !! ** Method : The thickness is calculated from a prognostic equation 2164 !! that relaxes the pycnocine thickness to a diagnostic 2165 !! value. The time change is calculated assuming the 2166 !! thickness relaxes exponentially. This is done to deal 2167 !! with large timesteps. 2168 !! 2169 !!---------------------------------------------------------------------- 2170 2171 REAL(wp), DIMENSION(jpi,jpj) :: dh, zdh ! pycnocline thickness. 2172 ! 2173 INTEGER :: jj, ji 2174 INTEGER :: inhml 2175 REAL(wp) :: zari, ztau, zdh_ref 2176 REAL, PARAMETER :: a_ddh_2 = 3.5 ! also in pycnocline_depth 2177 2178 DO_2D( 0, 0, 0, 0 ) 2179 2180 IF ( lshear(ji,jj) ) THEN 2181 IF ( lconv(ji,jj) ) THEN 2182 IF ( j_ddh(ji,jj) == 0 ) THEN 2183 ! ddhdt for pycnocline determined in osm_calculate_dhdt 2184 dh(ji,jj) = dh(ji,jj) + zddhdt(ji,jj) * rn_Dt 2185 ELSE 2186 ! Temporary (probably) Recalculate dh_ref to ensure dh doesn't go negative. Can't do this using zddhdt from calculate_dhdt 2187 IF ( ( zwstrc(ji,jj) / zvstr(ji,jj) )**3 <= 0.5 ) THEN 2188 zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zvstr(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 2189 ELSE 2190 zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zwstrc(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 2191 ENDIF 2192 ztau = MAX( zdb_bl(ji,jj) * ( zari * hbl(ji,jj) ) / ( a_ddh_2 * MAX(-zwb_ent(ji,jj), 1.e-12) ), 2.0 * rn_Dt ) 2193 dh(ji,jj) = dh(ji,jj) * EXP( -rn_Dt / ztau ) + zari * zhbl(ji,jj) * ( 1.0 - EXP( -rn_Dt / ztau ) ) 2194 IF ( dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zari * zhbl(ji,jj) 2195 ENDIF 2196 2197 ELSE ! lconv 2198 ! Initially shear only for entraining OSBL. Stable code will be needed if extended to stable OSBL 2199 2200 ztau = hbl(ji,jj) / MAX(zvstr(ji,jj), epsln) 2201 IF ( zdhdt(ji,jj) >= 0.0 ) THEN ! probably shouldn't include wm here 2202 ! boundary layer deepening 2203 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 2204 ! pycnocline thickness set by stratification - use same relationship as for neutral conditions. 2205 zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & 2206 & / MAX(zdb_bl(ji,jj) * zhbl(ji,jj), epsln ) + 0.01 , 0.2 ) 2207 zdh_ref = MIN( zari, 0.2 ) * hbl(ji,jj) 2208 ELSE 2209 zdh_ref = 0.2 * hbl(ji,jj) 2210 ENDIF 2211 ELSE ! IF(dhdt < 0) 2212 zdh_ref = 0.2 * hbl(ji,jj) 2213 ENDIF ! IF (dhdt >= 0) 2214 dh(ji,jj) = dh(ji,jj) * EXP( -rn_Dt / ztau )+ zdh_ref * ( 1.0 - EXP( -rn_Dt / ztau ) ) 2215 IF ( zdhdt(ji,jj) < 0._wp .and. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref ! can be a problem with dh>hbl for rapid collapse 2216 ! Alan: this hml is never defined or used -- do we need it? 2217 ENDIF 2218 2219 ELSE ! lshear 2220 ! for lshear = .FALSE. calculate ddhdt here 2221 2222 IF ( lconv(ji,jj) ) THEN 2223 2224 IF( ln_osm_mle ) THEN 2225 IF ( ( zwb_ent(ji,jj) + 2.0 * zwb_fk_b(ji,jj) ) < 0._wp ) THEN 2226 ! OSBL is deepening. Note wb_fk_b is zero if ln_osm_mle=F 2227 IF ( zdb_bl(ji,jj) > 0._wp .and. zdbdz_bl_ext(ji,jj) > 0._wp)THEN 2228 IF ( ( zwstrc(ji,jj) / MAX(zvstr(ji,jj), epsln) )**3 <= 0.5 ) THEN ! near neutral stability 2229 zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zvstr(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 2230 ELSE ! unstable 2231 zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zwstrc(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 2232 ENDIF 2233 ztau = 0.2 * hbl(ji,jj) / MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 2234 zdh_ref = zari * hbl(ji,jj) 2235 ELSE 2236 ztau = 0.2 * hbl(ji,jj) / MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 2237 zdh_ref = 0.2 * hbl(ji,jj) 2238 ENDIF 2239 ELSE 2240 ztau = 0.2 * hbl(ji,jj) / MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 2241 zdh_ref = 0.2 * hbl(ji,jj) 2242 ENDIF 2243 ELSE ! ln_osm_mle 2244 IF ( zdb_bl(ji,jj) > 0._wp .and. zdbdz_bl_ext(ji,jj) > 0._wp)THEN 2245 IF ( ( zwstrc(ji,jj) / MAX(zvstr(ji,jj), epsln) )**3 <= 0.5 ) THEN ! near neutral stability 2246 zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zvstr(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 2247 ELSE ! unstable 2248 zari = MIN( 1.5 * zdb_bl(ji,jj) / ( zhbl(ji,jj) * ( MAX(zdbdz_bl_ext(ji,jj),0._wp) + zdb_bl(ji,jj)**2 / MAX(4.5 * zwstrc(ji,jj)**2 , 1.e-12 )) ), 0.2d0 ) 2249 ENDIF 2250 ztau = hbl(ji,jj) / MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 2251 zdh_ref = zari * hbl(ji,jj) 2252 ELSE 2253 ztau = hbl(ji,jj) / MAX(epsln, (zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3)**pthird) 2254 zdh_ref = 0.2 * hbl(ji,jj) 2255 ENDIF 2256 2257 END IF ! ln_osm_mle 2258 2259 dh(ji,jj) = dh(ji,jj) * EXP( -rn_Dt / ztau ) + zdh_ref * ( 1.0 - EXP( -rn_Dt / ztau ) ) 2260 ! IF ( zdhdt(ji,jj) < 0._wp .and. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref 2261 IF ( dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref 2262 ! Alan: this hml is never defined or used 2263 ELSE ! IF (lconv) 2264 ztau = hbl(ji,jj) / MAX(zvstr(ji,jj), epsln) 2265 IF ( zdhdt(ji,jj) >= 0.0 ) THEN ! probably shouldn't include wm here 2266 ! boundary layer deepening 2267 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 2268 ! pycnocline thickness set by stratification - use same relationship as for neutral conditions. 2269 zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & 2270 & / MAX(zdb_bl(ji,jj) * zhbl(ji,jj), epsln ) + 0.01 , 0.2 ) 2271 zdh_ref = MIN( zari, 0.2 ) * hbl(ji,jj) 2272 ELSE 2273 zdh_ref = 0.2 * hbl(ji,jj) 2274 ENDIF 2275 ELSE ! IF(dhdt < 0) 2276 zdh_ref = 0.2 * hbl(ji,jj) 2277 ENDIF ! IF (dhdt >= 0) 2278 dh(ji,jj) = dh(ji,jj) * EXP( -rn_Dt / ztau )+ zdh_ref * ( 1.0 - EXP( -rn_Dt / ztau ) ) 2279 IF ( zdhdt(ji,jj) < 0._wp .and. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref ! can be a problem with dh>hbl for rapid collapse 2280 ENDIF ! IF (lconv) 2281 ENDIF ! lshear 2282 2283 hml(ji,jj) = hbl(ji,jj) - dh(ji,jj) 2284 inhml = MAX( INT( dh(ji,jj) / MAX(e3t(ji,jj,ibld(ji,jj),Kmm), 1.e-3) ) , 1 ) 2285 imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 3) 2286 zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) 2287 zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) 2288 END_2D 2289 2290 END SUBROUTINE zdf_osm_pycnocline_thickness 2291 2292 2293 SUBROUTINE zdf_osm_zmld_horizontal_gradients( zmld, zdtdx, zdtdy, zdsdx, zdsdy, dbdx_mle, dbdy_mle, zdbds_mle ) 2294 !!---------------------------------------------------------------------- 2295 !! *** ROUTINE zdf_osm_horizontal_gradients *** 2296 !! 2297 !! ** Purpose : Calculates horizontal gradients of buoyancy for use with Fox-Kemper parametrization. 2298 !! 2299 !! ** Method : 2300 !! 2301 !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 2302 !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 2303 2304 2305 REAL(wp), DIMENSION(jpi,jpj) :: dbdx_mle, dbdy_mle ! MLE horiz gradients at u & v points 2306 REAL(wp), DIMENSION(jpi,jpj) :: zdbds_mle ! Magnitude of horizontal buoyancy gradient. 2307 REAL(wp), DIMENSION(jpi,jpj) :: zmld ! == estimated FK BLD used for MLE horiz gradients == ! 2308 REAL(wp), DIMENSION(jpi,jpj) :: zdtdx, zdtdy, zdsdx, zdsdy 2309 2310 INTEGER :: ji, jj, jk ! dummy loop indices 2311 INTEGER :: ii, ij, ik, ikmax ! local integers 2312 REAL(wp) :: zc 2313 REAL(wp) :: zN2_c ! local buoyancy difference from 10m value 2314 REAL(wp), DIMENSION(jpi,jpj) :: ztm, zsm, zLf_NH, zLf_MH 2315 REAL(wp), DIMENSION(jpi,jpj,jpts):: ztsm_midu, ztsm_midv, zabu, zabv 2316 REAL(wp), DIMENSION(jpi,jpj) :: zmld_midu, zmld_midv 2317 !!---------------------------------------------------------------------- 2318 ! 2319 ! !== MLD used for MLE ==! 2320 2321 mld_prof(:,:) = nlb10 ! Initialization to the number of w ocean point 2322 zmld(:,:) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2 2323 zN2_c = grav * rn_osm_mle_rho_c * r1_rho0 ! convert density criteria into N^2 criteria 2324 DO_3D( 1, 1, 1, 1, nlb10, jpkm1 ) 2325 ikt = mbkt(ji,jj) 2326 zmld(ji,jj) = zmld(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) 2327 IF( zmld(ji,jj) < zN2_c ) mld_prof(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level 2328 END_3D 2329 DO_2D( 1, 1, 1, 1 ) 2330 mld_prof(ji,jj) = MAX(mld_prof(ji,jj),ibld(ji,jj)) 2331 zmld(ji,jj) = gdepw(ji,jj,mld_prof(ji,jj),Kmm) 2332 END_2D 2333 ! ensure mld_prof .ge. ibld 2334 ! 2335 ikmax = MIN( MAXVAL( mld_prof(:,:) ), jpkm1 ) ! max level of the computation 2336 ! 2337 ztm(:,:) = 0._wp 2338 zsm(:,:) = 0._wp 2339 DO_3D( 1, 1, 1, 1, 1, ikmax ) 2340 zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, mld_prof(ji,jj)-jk ) , 1 ) ) ! zc being 0 outside the ML t-points 2341 ztm(ji,jj) = ztm(ji,jj) + zc * ts(ji,jj,jk,jp_tem,Kmm) 2342 zsm(ji,jj) = zsm(ji,jj) + zc * ts(ji,jj,jk,jp_sal,Kmm) 2343 END_3D 2344 ! average temperature and salinity. 2345 ztm(:,:) = ztm(:,:) / MAX( e3t(:,:,1,Kmm), zmld(:,:) ) 2346 zsm(:,:) = zsm(:,:) / MAX( e3t(:,:,1,Kmm), zmld(:,:) ) 2347 ! calculate horizontal gradients at u & v points 2348 2349 DO_2D( 0, 0, 1, 0 ) 2350 zdtdx(ji,jj) = ( ztm(ji+1,jj) - ztm( ji,jj) ) * umask(ji,jj,1) / e1u(ji,jj) 2351 zdsdx(ji,jj) = ( zsm(ji+1,jj) - zsm( ji,jj) ) * umask(ji,jj,1) / e1u(ji,jj) 2352 zmld_midu(ji,jj) = 0.25_wp * (zmld(ji+1,jj) + zmld( ji,jj)) 2353 ztsm_midu(ji,jj,jp_tem) = 0.5_wp * ( ztm(ji+1,jj) + ztm( ji,jj) ) 2354 ztsm_midu(ji,jj,jp_sal) = 0.5_wp * ( zsm(ji+1,jj) + zsm( ji,jj) ) 2355 END_2D 2356 2357 DO_2D( 1, 0, 0, 0 ) 2358 zdtdy(ji,jj) = ( ztm(ji,jj+1) - ztm( ji,jj) ) * vmask(ji,jj,1) / e1v(ji,jj) 2359 zdsdy(ji,jj) = ( zsm(ji,jj+1) - zsm( ji,jj) ) * vmask(ji,jj,1) / e1v(ji,jj) 2360 zmld_midv(ji,jj) = 0.25_wp * (zmld(ji,jj+1) + zmld( ji,jj)) 2361 ztsm_midv(ji,jj,jp_tem) = 0.5_wp * ( ztm(ji,jj+1) + ztm( ji,jj) ) 2362 ztsm_midv(ji,jj,jp_sal) = 0.5_wp * ( zsm(ji,jj+1) + zsm( ji,jj) ) 2363 END_2D 2364 2365 CALL eos_rab(ztsm_midu, zmld_midu, zabu, Kmm) 2366 CALL eos_rab(ztsm_midv, zmld_midv, zabv, Kmm) 2367 2368 DO_2D( 0, 0, 1, 0 ) 2369 dbdx_mle(ji,jj) = grav*(zdtdx(ji,jj)*zabu(ji,jj,jp_tem) - zdsdx(ji,jj)*zabu(ji,jj,jp_sal)) 2370 END_2D 2371 DO_2D( 1, 0, 0, 0 ) 2372 dbdy_mle(ji,jj) = grav*(zdtdy(ji,jj)*zabv(ji,jj,jp_tem) - zdsdy(ji,jj)*zabv(ji,jj,jp_sal)) 2373 END_2D 2374 2375 DO_2D( 0, 0, 0, 0 ) 2376 ztmp = r1_ft(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) / rn_osm_mle_lf 2377 zdbds_mle(ji,jj) = SQRT( 0.5_wp * ( dbdx_mle(ji,jj) * dbdx_mle(ji,jj) + dbdy_mle(ji,jj) * dbdy_mle(ji,jj) & 2378 & + dbdx_mle(ji-1,jj) * dbdx_mle(ji-1,jj) + dbdy_mle(ji,jj-1) * dbdy_mle(ji,jj-1) ) ) 2379 END_2D 2380 2381 END SUBROUTINE zdf_osm_zmld_horizontal_gradients 2382 SUBROUTINE zdf_osm_mle_parameters( mld_prof, hmle, zhmle, zvel_mle, zdiff_mle ) 2383 !!---------------------------------------------------------------------- 2384 !! *** ROUTINE zdf_osm_mle_parameters *** 2385 !! 2386 !! ** Purpose : Timesteps the mixed layer eddy depth, hmle and calculates the mixed layer eddy fluxes for buoyancy, heat and salinity. 2387 !! 2388 !! ** Method : 2389 !! 2390 !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 2391 !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 2392 2393 INTEGER, DIMENSION(jpi,jpj) :: mld_prof 2394 REAL(wp), DIMENSION(jpi,jpj) :: hmle, zhmle, zwb_fk, zvel_mle, zdiff_mle 2395 INTEGER :: ji, jj, jk ! dummy loop indices 2396 INTEGER :: ii, ij, ik, jkb, jkb1 ! local integers 2397 INTEGER , DIMENSION(jpi,jpj) :: inml_mle 2398 REAL(wp) :: ztmp, zdbdz, zdtdz, zdsdz, zthermal,zbeta, zbuoy, zdb_mle 2399 2400 ! Calculate vertical buoyancy, heat and salinity fluxes due to MLE. 2401 2402 DO_2D( 0, 0, 0, 0 ) 2403 IF ( lconv(ji,jj) ) THEN 2404 ztmp = r1_ft(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) / rn_osm_mle_lf 2405 ! This velocity scale, defined in Fox-Kemper et al (2008), is needed for calculating dhdt. 2406 zvel_mle(ji,jj) = zdbds_mle(ji,jj) * ztmp * hmle(ji,jj) * tmask(ji,jj,1) 2407 zdiff_mle(ji,jj) = 5.e-4_wp * rn_osm_mle_ce * ztmp * zdbds_mle(ji,jj) * zhmle(ji,jj)**2 2408 ENDIF 2409 END_2D 2410 ! Timestep mixed layer eddy depth. 2411 DO_2D( 0, 0, 0, 0 ) 2412 IF ( lmle(ji,jj) ) THEN ! MLE layer growing. 2413 ! Buoyancy gradient at base of MLE layer. 2414 zthermal = rab_n(ji,jj,1,jp_tem) 2415 zbeta = rab_n(ji,jj,1,jp_sal) 2416 jkb = mld_prof(ji,jj) 2417 jkb1 = MIN(jkb + 1, mbkt(ji,jj)) 2418 ! 2419 zbuoy = grav * ( zthermal * ts(ji,jj,mld_prof(ji,jj)+2,jp_tem,Kmm) - zbeta * ts(ji,jj,mld_prof(ji,jj)+2,jp_sal,Kmm) ) 2420 zdb_mle = zb_bl(ji,jj) - zbuoy 2421 ! Timestep hmle. 2422 hmle(ji,jj) = hmle(ji,jj) + zwb0(ji,jj) * rn_Dt / zdb_mle 2423 ELSE 2424 IF ( zhmle(ji,jj) > zhbl(ji,jj) ) THEN 2425 hmle(ji,jj) = hmle(ji,jj) - ( hmle(ji,jj) - hbl(ji,jj) ) * rn_Dt / rn_osm_mle_tau 2426 ELSE 2427 hmle(ji,jj) = hmle(ji,jj) - 10.0 * ( hmle(ji,jj) - hbl(ji,jj) ) * rn_Dt /rn_osm_mle_tau 2428 ENDIF 2429 ENDIF 2430 hmle(ji,jj) = MIN(hmle(ji,jj), ht(ji,jj)) 2431 IF(ln_osm_hmle_limit) hmle(ji,jj) = MIN(hmle(ji,jj), MAX(rn_osm_hmle_limit,1.2*hbl(ji,jj)) ) 2432 END_2D 2433 2434 mld_prof = 4 2435 DO_3D( 0, 0, 0, 0, 5, jpkm1 ) 2436 IF ( hmle(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) mld_prof(ji,jj) = MIN(mbkt(ji,jj), jk) 2437 END_3D 2438 DO_2D( 0, 0, 0, 0 ) 2439 zhmle(ji,jj) = gdepw(ji,jj, mld_prof(ji,jj),Kmm) 2440 END_2D 2441 END SUBROUTINE zdf_osm_mle_parameters 2442 2443 END SUBROUTINE zdf_osm 2444 2445 2446 SUBROUTINE zdf_osm_init( Kmm ) 1295 2447 !!---------------------------------------------------------------------- 1296 2448 !! *** ROUTINE zdf_osm_init *** … … 1304 2456 !! ** input : Namlist namosm 1305 2457 !!---------------------------------------------------------------------- 1306 INTEGER, INTENT(in) :: Kmm ! time level index (middle) 1307 ! 2458 INTEGER, INTENT(in) :: Kmm ! time level 1308 2459 INTEGER :: ios ! local integer 1309 2460 INTEGER :: ji, jj, jk ! dummy loop indices 2461 REAL z1_t2 1310 2462 !! 1311 2463 NAMELIST/namzdf_osm/ ln_use_osm_la, rn_osm_la, rn_osm_dstokes, nn_ave & 1312 & ,nn_osm_wave, ln_dia_osm, rn_osm_hbl0 & 1313 & ,ln_kpprimix, rn_riinfty, rn_difri, ln_convmix, rn_difconv 2464 & ,nn_osm_wave, ln_dia_osm, rn_osm_hbl0, rn_zdfosm_adjust_sd & 2465 & ,ln_kpprimix, rn_riinfty, rn_difri, ln_convmix, rn_difconv, nn_osm_wave & 2466 & ,nn_osm_SD_reduce, ln_osm_mle, rn_osm_hblfrac, rn_osm_bl_thresh, ln_zdfosm_ice_shelter 2467 ! Namelist for Fox-Kemper parametrization. 2468 NAMELIST/namosm_mle/ nn_osm_mle, rn_osm_mle_ce, rn_osm_mle_lf, rn_osm_mle_time, rn_osm_mle_lat,& 2469 & rn_osm_mle_rho_c, rn_osm_mle_thresh, rn_osm_mle_tau, ln_osm_hmle_limit, rn_osm_hmle_limit 2470 1314 2471 !!---------------------------------------------------------------------- 1315 2472 ! … … 1325 2482 WRITE(numout,*) 'zdf_osm_init : OSMOSIS Parameterisation' 1326 2483 WRITE(numout,*) '~~~~~~~~~~~~' 1327 WRITE(numout,*) ' Namelist namzdf_osm : set tke mixing parameters' 1328 WRITE(numout,*) ' Use namelist rn_osm_la ln_use_osm_la = ', ln_use_osm_la 2484 WRITE(numout,*) ' Namelist namzdf_osm : set osm mixing parameters' 2485 WRITE(numout,*) ' Use rn_osm_la ln_use_osm_la = ', ln_use_osm_la 2486 WRITE(numout,*) ' Use MLE in OBL, i.e. Fox-Kemper param ln_osm_mle = ', ln_osm_mle 1329 2487 WRITE(numout,*) ' Turbulent Langmuir number rn_osm_la = ', rn_osm_la 2488 WRITE(numout,*) ' Stokes drift reduction factor rn_zdfosm_adjust_sd = ', rn_zdfosm_adjust_sd 1330 2489 WRITE(numout,*) ' Initial hbl for 1D runs rn_osm_hbl0 = ', rn_osm_hbl0 1331 WRITE(numout,*) ' Depth scale of Stokes drift rn_osm_dstokes = ', rn_osm_dstokes2490 WRITE(numout,*) ' Depth scale of Stokes drift rn_osm_dstokes = ', rn_osm_dstokes 1332 2491 WRITE(numout,*) ' horizontal average flag nn_ave = ', nn_ave 1333 2492 WRITE(numout,*) ' Stokes drift nn_osm_wave = ', nn_osm_wave … … 1339 2498 CASE(2) 1340 2499 WRITE(numout,*) ' calculated from ECMWF wave fields' 2500 END SELECT 2501 WRITE(numout,*) ' Stokes drift reduction nn_osm_SD_reduce', nn_osm_SD_reduce 2502 WRITE(numout,*) ' fraction of hbl to average SD over/fit' 2503 WRITE(numout,*) ' exponential with nn_osm_SD_reduce = 1 or 2 rn_osm_hblfrac = ', rn_osm_hblfrac 2504 SELECT CASE (nn_osm_SD_reduce) 2505 CASE(0) 2506 WRITE(numout,*) ' No reduction' 2507 CASE(1) 2508 WRITE(numout,*) ' Average SD over upper rn_osm_hblfrac of BL' 2509 CASE(2) 2510 WRITE(numout,*) ' Fit exponential to slope rn_osm_hblfrac of BL' 1341 2511 END SELECT 2512 WRITE(numout,*) ' reduce surface SD and depth scale under ice ln_zdfosm_ice_shelter=', ln_zdfosm_ice_shelter 1342 2513 WRITE(numout,*) ' Output osm diagnostics ln_dia_osm = ', ln_dia_osm 2514 WRITE(numout,*) ' Threshold used to define BL rn_osm_bl_thresh = ', rn_osm_bl_thresh, 'm^2/s' 1343 2515 WRITE(numout,*) ' Use KPP-style shear instability mixing ln_kpprimix = ', ln_kpprimix 1344 2516 WRITE(numout,*) ' local Richardson Number limit for shear instability rn_riinfty = ', rn_riinfty … … 1359 2531 IF( zdf_osm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_osm_init : unable to allocate arrays' ) 1360 2532 1361 call osm_rst( nit000, Kmm, 'READ' ) !* read or initialize hbl 2533 2534 IF( ln_osm_mle ) THEN 2535 ! Initialise Fox-Kemper parametrization 2536 READ ( numnam_ref, namosm_mle, IOSTAT = ios, ERR = 903) 2537 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namosm_mle in reference namelist') 2538 2539 READ ( numnam_cfg, namosm_mle, IOSTAT = ios, ERR = 904 ) 2540 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namosm_mle in configuration namelist') 2541 IF(lwm) WRITE ( numond, namosm_mle ) 2542 2543 IF(lwp) THEN ! Namelist print 2544 WRITE(numout,*) 2545 WRITE(numout,*) 'zdf_osm_init : initialise mixed layer eddy (MLE)' 2546 WRITE(numout,*) '~~~~~~~~~~~~~' 2547 WRITE(numout,*) ' Namelist namosm_mle : ' 2548 WRITE(numout,*) ' MLE type: =0 standard Fox-Kemper ; =1 new formulation nn_osm_mle = ', nn_osm_mle 2549 WRITE(numout,*) ' magnitude of the MLE (typical value: 0.06 to 0.08) rn_osm_mle_ce = ', rn_osm_mle_ce 2550 WRITE(numout,*) ' scale of ML front (ML radius of deformation) (nn_osm_mle=0) rn_osm_mle_lf = ', rn_osm_mle_lf, 'm' 2551 WRITE(numout,*) ' maximum time scale of MLE (nn_osm_mle=0) rn_osm_mle_time = ', rn_osm_mle_time, 's' 2552 WRITE(numout,*) ' reference latitude (degrees) of MLE coef. (nn_osm_mle=1) rn_osm_mle_lat = ', rn_osm_mle_lat, 'deg' 2553 WRITE(numout,*) ' Density difference used to define ML for FK rn_osm_mle_rho_c = ', rn_osm_mle_rho_c 2554 WRITE(numout,*) ' Threshold used to define MLE for FK rn_osm_mle_thresh = ', rn_osm_mle_thresh, 'm^2/s' 2555 WRITE(numout,*) ' Timescale for OSM-FK rn_osm_mle_tau = ', rn_osm_mle_tau, 's' 2556 WRITE(numout,*) ' switch to limit hmle ln_osm_hmle_limit = ', ln_osm_hmle_limit 2557 WRITE(numout,*) ' fraction of zmld to limit hmle to if ln_osm_hmle_limit =.T. rn_osm_hmle_limit = ', rn_osm_hmle_limit 2558 ENDIF ! 2559 ENDIF 2560 ! 2561 IF(lwp) THEN 2562 WRITE(numout,*) 2563 IF( ln_osm_mle ) THEN 2564 WRITE(numout,*) ' ==>>> Mixed Layer Eddy induced transport added to OSMOSIS BL calculation' 2565 IF( nn_osm_mle == 0 ) WRITE(numout,*) ' Fox-Kemper et al 2010 formulation' 2566 IF( nn_osm_mle == 1 ) WRITE(numout,*) ' New formulation' 2567 ELSE 2568 WRITE(numout,*) ' ==>>> Mixed Layer induced transport NOT added to OSMOSIS BL calculation' 2569 ENDIF 2570 ENDIF 2571 ! 2572 IF( ln_osm_mle ) THEN ! MLE initialisation 2573 ! 2574 rb_c = grav * rn_osm_mle_rho_c /rho0 ! Mixed Layer buoyancy criteria 2575 IF(lwp) WRITE(numout,*) 2576 IF(lwp) WRITE(numout,*) ' ML buoyancy criteria = ', rb_c, ' m/s2 ' 2577 IF(lwp) WRITE(numout,*) ' associated ML density criteria defined in zdfmxl = ', rn_osm_mle_rho_c, 'kg/m3' 2578 ! 2579 IF( nn_osm_mle == 0 ) THEN ! MLE array allocation & initialisation ! 2580 ! 2581 ELSEIF( nn_osm_mle == 1 ) THEN ! MLE array allocation & initialisation 2582 rc_f = rn_osm_mle_ce/ ( 5.e3_wp * 2._wp * omega * SIN( rad * rn_osm_mle_lat ) ) 2583 ! 2584 ENDIF 2585 ! ! 1/(f^2+tau^2)^1/2 at t-point (needed in both nn_osm_mle case) 2586 z1_t2 = 2.e-5 2587 DO_2D( 1, 1, 1, 1 ) 2588 r1_ft(ji,jj) = MIN(1./( ABS(ff_t(ji,jj)) + epsln ), ABS(ff_t(ji,jj))/z1_t2**2) 2589 END_2D 2590 ! z1_t2 = 1._wp / ( rn_osm_mle_time * rn_osm_mle_timeji,jj ) 2591 ! r1_ft(:,:) = 1._wp / SQRT( ff_t(:,:) * ff_t(:,:) + z1_t2 ) 2592 ! 2593 ENDIF 2594 2595 call osm_rst( nit000, Kmm, 'READ' ) !* read or initialize hbl, dh, hmle 2596 1362 2597 1363 2598 IF( ln_zdfddm) THEN … … 1454 2689 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 1455 2690 1456 INTEGER :: id1, id2 ! iom enquiry index2691 INTEGER :: id1, id2, id3 ! iom enquiry index 1457 2692 INTEGER :: ji, jj, jk ! dummy loop indices 1458 2693 INTEGER :: iiki, ikt ! local integer … … 1460 2695 REAL(wp) :: zN2_c ! local scalar 1461 2696 REAL(wp) :: rho_c = 0.01_wp !: density criterion for mixed layer depth 1462 INTEGER, DIMENSION( :,:), ALLOCATABLE:: imld_rst ! level of mixed-layer depth (pycnocline top)2697 INTEGER, DIMENSION(jpi,jpj) :: imld_rst ! level of mixed-layer depth (pycnocline top) 1463 2698 !!---------------------------------------------------------------------- 1464 2699 ! … … 1470 2705 IF( id1 > 0 ) THEN ! 'wn' exists; read 1471 2706 CALL iom_get( numror, jpdom_auto, 'wn', ww ) 1472 WRITE(numout,*) ' ===>>>> : w wread from restart file'2707 WRITE(numout,*) ' ===>>>> : wn read from restart file' 1473 2708 ELSE 1474 2709 ww(:,:,:) = 0._wp 1475 WRITE(numout,*) ' ===>>>> : w wnot in restart file, set to zero initially'2710 WRITE(numout,*) ' ===>>>> : wn not in restart file, set to zero initially' 1476 2711 END IF 2712 1477 2713 id1 = iom_varid( numror, 'hbl' , ldstop = .FALSE. ) 1478 id2 = iom_varid( numror, ' hbli' , ldstop = .FALSE. )2714 id2 = iom_varid( numror, 'dh' , ldstop = .FALSE. ) 1479 2715 IF( id1 > 0 .AND. id2 > 0) THEN ! 'hbl' exists; read and return 1480 2716 CALL iom_get( numror, jpdom_auto, 'hbl' , hbl ) 1481 CALL iom_get( numror, jpdom_auto, 'hbli', hbli ) 1482 WRITE(numout,*) ' ===>>>> : hbl & hbli read from restart file' 2717 CALL iom_get( numror, jpdom_auto, 'dh', dh ) 2718 WRITE(numout,*) ' ===>>>> : hbl & dh read from restart file' 2719 IF( ln_osm_mle ) THEN 2720 id3 = iom_varid( numror, 'hmle' , ldstop = .FALSE. ) 2721 IF( id3 > 0) THEN 2722 CALL iom_get( numror, jpdom_auto, 'hmle' , hmle ) 2723 WRITE(numout,*) ' ===>>>> : hmle read from restart file' 2724 ELSE 2725 WRITE(numout,*) ' ===>>>> : hmle not found, set to hbl' 2726 hmle(:,:) = hbl(:,:) ! Initialise MLE depth. 2727 END IF 2728 END IF 1483 2729 RETURN 1484 ELSE ! 'hbl' & ' hbli' not in restart file, recalculate2730 ELSE ! 'hbl' & 'dh' not in restart file, recalculate 1485 2731 WRITE(numout,*) ' ===>>>> : previous run without osmosis scheme, hbl computed from stratification' 1486 2732 END IF … … 1490 2736 ! If READ/WRITE Flag is 'WRITE', write hbl into the restart file, then return 1491 2737 !!----------------------------------------------------------------------------- 1492 IF( TRIM(cdrw) == 'WRITE') THEN !* Write hbli into the restart file, then return 1493 IF( ntile /= 0 .AND. ntile /= nijtile ) RETURN ! Do only on the last tile 1494 2738 IF( TRIM(cdrw) == 'WRITE') THEN !* Write hbl into the restart file, then return 1495 2739 IF(lwp) WRITE(numout,*) '---- osm-rst ----' 1496 CALL iom_rstput( kt, nitrst, numrow, 'wn' , ww ) 1497 CALL iom_rstput( kt, nitrst, numrow, 'hbl' , hbl ) 1498 CALL iom_rstput( kt, nitrst, numrow, 'hbli' , hbli ) 2740 CALL iom_rstput( kt, nitrst, numrow, 'wn' , ww ) 2741 CALL iom_rstput( kt, nitrst, numrow, 'hbl' , hbl ) 2742 CALL iom_rstput( kt, nitrst, numrow, 'dh' , dh ) 2743 IF( ln_osm_mle ) THEN 2744 CALL iom_rstput( kt, nitrst, numrow, 'hmle', hmle ) 2745 END IF 1499 2746 RETURN 1500 2747 END IF … … 1504 2751 !!----------------------------------------------------------------------------- 1505 2752 IF( lwp ) WRITE(numout,*) ' ===>>>> : calculating hbl computed from stratification' 1506 ALLOCATE( imld_rst(jpi,jpj) )1507 2753 ! w-level of the mixing and mixed layers 1508 2754 CALL eos_rab( ts(:,:,:,:,Kmm), rab_n, Kmm ) … … 1513 2759 ! 1514 2760 hbl(:,:) = 0._wp ! here hbl used as a dummy variable, integrating vertically N^2 1515 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! Mixed layer level: w-level2761 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 1516 2762 ikt = mbkt(ji,jj) 1517 2763 hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) … … 1520 2766 ! 1521 2767 DO_2D( 1, 1, 1, 1 ) 1522 iiki = imld_rst(ji,jj) 1523 hbl (ji,jj) = gdepw(ji,jj,iiki ,Kmm) * ssmask(ji,jj) ! Turbocline depth 2768 iiki = MAX(4,imld_rst(ji,jj)) 2769 hbl (ji,jj) = gdepw(ji,jj,iiki,Kmm ) ! Turbocline depth 2770 dh (ji,jj) = e3t(ji,jj,iiki-1,Kmm ) ! Turbocline depth 1524 2771 END_2D 1525 hbl = MAX(hbl,epsln) 1526 hbli(:,:) = hbl(:,:) 1527 DEALLOCATE( imld_rst ) 2772 1528 2773 WRITE(numout,*) ' ===>>>> : hbl computed from stratification' 2774 2775 IF( ln_osm_mle ) THEN 2776 hmle(:,:) = hbl(:,:) ! Initialise MLE depth. 2777 WRITE(numout,*) ' ===>>>> : hmle set = to hbl' 2778 END IF 2779 2780 ww(:,:,:) = 0._wp 2781 WRITE(numout,*) ' ===>>>> : wn not in restart file, set to zero initially' 1529 2782 END SUBROUTINE osm_rst 1530 2783 … … 1559 2812 ENDIF 1560 2813 1561 ! add non-local temperature and salinity flux1562 2814 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 1563 2815 pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & … … 1569 2821 END_3D 1570 2822 1571 1572 ! save the non-local tracer flux trends for diagnostic 2823 ! save the non-local tracer flux trends for diagnostics 1573 2824 IF( l_trdtra ) THEN 1574 2825 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 1575 2826 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 1576 !!bug gm jpttdzdf ==> jpttosm 1577 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ zdf, ztrdt )1578 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ zdf, ztrds )2827 2828 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_osm, ztrdt ) 2829 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_osm, ztrds ) 1579 2830 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 1580 2831 ENDIF … … 1642 2893 1643 2894 !!====================================================================== 2895 1644 2896 END MODULE zdfosm -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ZDF/zdfphy.F90
r14037 r14062 179 179 IF( ln_zdfmfc .AND. ln_zdfosm ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfosm' ) 180 180 IF( lk_top .AND. ln_zdfnpc ) CALL ctl_stop( 'zdf_phy_init: npc scheme is not working with key_top' ) 181 IF( lk_top .AND. ln_zdfosm ) CALL ctl_ stop( 'zdf_phy_init: osmosis scheme is not working with key_top' )181 IF( lk_top .AND. ln_zdfosm ) CALL ctl_warn( 'zdf_phy_init: osmosis gives no non-local fluxes for TOP tracers yet' ) 182 182 IF( lk_top .AND. ln_zdfmfc ) CALL ctl_stop( 'zdf_phy_init: Mass Flux scheme is not working with key_top' ) 183 183 IF(lwp) THEN -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/ZDF/zdftke.F90
r14037 r14062 242 242 ! 243 243 DO_2D( 0, 0, 0, 0 ) 244 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1)244 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) 245 245 zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) 246 246 zd_lw(ji,jj,1) = 1._wp -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/nemogcm.F90
r14044 r14062 42 42 !!---------------------------------------------------------------------- 43 43 USE step_oce ! module used in the ocean time stepping module (step.F90) 44 ! 44 45 USE phycst ! physical constant (par_cst routine) 45 46 USE domain ! domain initialization (dom_init & dom_cfg routines) 46 USE closea ! treatment of closed seas (for ln_closea)47 USE usrdef_nam ! user defined configuration 48 USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine)49 USE bdyini 47 USE wet_dry ! Wetting and drying setting (wad_init routine) 48 USE usrdef_nam ! user defined configuration namelist 49 USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine) 50 USE bdyini , ONLY : bdy_init ! open boundary cond. setting (bdy_init routine) 50 51 USE istate ! initial state setting (istate_init routine) 51 USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine)52 USE ldftra ! lateral diffusivity setting (ldftra_init routine)53 52 USE trdini ! dyn/tra trends initialization (trd_init routine) 54 USE asminc ! assimilation increments 55 USE asmbkg ! writing out state trajectory 56 USE diadct ! sections transports (dia_dct_init routine) 57 USE diaobs ! Observation diagnostics (dia_obs_init routine) 58 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 59 USE diamlr ! IOM context management for multiple-linear-regression analysis 53 USE icbini ! handle bergs, initialisation 54 USE icbstp , ONLY : icb_end ! handle bergs, close iceberg files 55 USE cpl_oasis3 ! OASIS3 coupling 56 USE dyndmp ! Momentum damping (C1D only) 57 USE step_diu ! diurnal bulk SST timestepping (called from here if run offline) 58 USE crsini ! initialise grid coarsening utility 59 USE dia25h , ONLY : dia_25h_init ! 25h mean output (initialisation) 60 USE c1d ! 1D configuration 61 USE step_c1d ! Time stepping loop for the 1D configuration 62 #if defined key_top 63 USE trcini ! passive tracer initialisation 64 #endif 65 #if defined key_nemocice_decomp 66 USE ice_domain_size, only: nx_global, ny_global 67 #endif 60 68 #if defined key_qco 61 USE st epMLF! NEMO time-stepping (stp_MLF routine)69 USE stpmlf ! NEMO time-stepping (stp_MLF routine) 62 70 #else 63 71 USE step ! NEMO time-stepping (stp routine) 64 72 #endif 65 USE isfstp ! ice shelf (isf_stp_init routine)66 USE icbini ! handle bergs, initialisation67 USE icbstp ! handle bergs, calving, themodynamics and transport68 USE cpl_oasis3 ! OASIS3 coupling69 USE c1d ! 1D configuration70 USE step_c1d ! Time stepping loop for the 1D configuration71 USE dyndmp ! Momentum damping72 USE stopar ! Stochastic param.: ???73 USE stopts ! Stochastic param.: ???74 USE diu_layers ! diurnal bulk SST and coolskin75 USE step_diu ! diurnal bulk SST timestepping (called from here if run offline)76 USE crsini ! initialise grid coarsening utility77 USE dia25h ! 25h mean output78 USE diadetide ! Weights computation for daily detiding of model diagnostics79 USE sbc_oce , ONLY : lk_oasis80 USE wet_dry ! Wetting and drying setting (wad_init routine)81 #if defined key_top82 USE trcini ! passive tracer initialisation83 #endif84 #if defined key_nemocice_decomp85 USE ice_domain_size, only: nx_global, ny_global86 #endif87 73 ! 88 USE prtctl ! Print control89 USE in_out_manager ! I/O manager90 74 USE lib_mpp ! distributed memory computing 91 75 USE mppini ! shared/distributed memory setting (mpp_init routine) 92 76 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 93 77 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 94 #if defined key_iomput 95 USE xios ! xIOserver 96 #endif 97 #if defined key_agrif 98 USE agrif_all_update ! Master Agrif update 99 #endif 100 USE halo_mng 78 USE halo_mng ! Halo manager 101 79 102 80 IMPLICIT NONE … … 182 160 ! 183 161 DO WHILE( istp <= nitend .AND. nstop == 0 ) 184 # if defined key_qco162 # if defined key_qco 185 163 CALL stp_MLF 186 # else164 # else 187 165 CALL stp 188 # endif166 # endif 189 167 istp = istp + 1 190 168 END DO … … 195 173 ! 196 174 DO WHILE( istp <= nitend .AND. nstop == 0 ) 197 175 ! 198 176 ncom_stp = istp 199 177 IF( ln_timing ) THEN … … 202 180 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 203 181 ENDIF 204 205 # if defined key_qco182 ! 183 # if defined key_qco 206 184 CALL stp_MLF ( istp ) 207 # else185 # else 208 186 CALL stp ( istp ) 209 # endif187 # endif 210 188 istp = istp + 1 211 189 ! 212 190 IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 213 191 ! 214 192 END DO 215 193 ! … … 279 257 INTEGER :: ios, ilocal_comm ! local integers 280 258 !! 281 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, 282 & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle259 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, nn_isplt, nn_jsplt , nn_ictls, & 260 & nn_ictle, nn_jctls , nn_jctle 283 261 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 284 262 !!---------------------------------------------------------------------- … … 350 328 IF(lwp) THEN ! open listing units 351 329 ! 352 IF( .NOT. 330 IF( .NOT.lwm ) & ! alreay opened for narea == 1 353 331 & CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 354 332 ! … … 357 335 WRITE(numout,*) ' NEMO team' 358 336 WRITE(numout,*) ' Ocean General Circulation Model' 359 WRITE(numout,*) ' NEMO version 4.0 (20 19) '337 WRITE(numout,*) ' NEMO version 4.0 (2020) ' 360 338 WRITE(numout,*) 361 339 WRITE(numout,*) " ._ ._ ._ ._ ._ " … … 373 351 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 374 352 WRITE(numout,*) 375 376 ! Print the working precision to ocean.output 377 IF (wp == dp) THEN 378 WRITE(numout,*) "Working precision = double-precision" 379 ELSE 380 WRITE(numout,*) "Working precision = single-precision" 353 ! 354 WRITE(numout,cform_aaa) ! Flag AAAAAAA 355 ! 356 ! ! Control print of the working precision 357 WRITE(numout,*) 358 IF( wp == dp ) THEN ; WRITE(numout,*) "par_kind : wp = Working precision = dp = double-precision" 359 ELSE ; WRITE(numout,*) "par_kind : wp = Working precision = sp = single-precision" 381 360 ENDIF 382 WRITE(numout,*) 383 ! 384 WRITE(numout,cform_aaa) ! Flag AAAAAAA 361 WRITE(numout,*) "~~~~~~~~ ****************" 362 WRITE(numout,*) 385 363 ! 386 364 ENDIF … … 415 393 416 394 ! Initialise time level indices 417 Nbb = 1 ; Nnn = 2; Naa = 3;Nrhs = Naa395 Nbb = 1 ; Nnn = 2 ; Naa = 3 ; Nrhs = Naa 418 396 #if defined key_agrif 419 Kbb_a = Nbb ; Kmm_a = Nnn;Krhs_a = Nrhs ! agrif_oce module copies of time level indices397 Kbb_a = Nbb ; Kmm_a = Nnn ; Krhs_a = Nrhs ! agrif_oce module copies of time level indices 420 398 #endif 421 399 ! !-------------------------------! … … 423 401 ! !-------------------------------! 424 402 425 CALL nemo_ctl ! Control prints 403 CALL nemo_ctl ! Control prints of namctl and namcfg 426 404 ! 427 405 ! ! General initialization … … 437 415 CALL Agrif_Declare_Var_ini ! " " " " " DOM 438 416 #endif 439 CALL dom_init( Nbb, Nnn, Naa ) ! Domain440 IF( ln_crs ) CALL crs_init( Nnn )! coarsened grid: domain initialization417 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 418 IF( ln_crs ) CALL crs_init( Nnn ) ! coarsened grid: domain initialization 441 419 IF( sn_cfctl%l_prtctl ) & 442 420 & CALL prt_ctl_init ! Print control -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/oce.F90
r13361 r14062 16 16 PRIVATE 17 17 18 PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 18 PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 19 PUBLIC oce_SWE_alloc ! routine called by nemo_init in SWE/nemogcm.F90 (Shallow Water Eq. case) 19 20 20 21 !! dynamics and tracer fields … … 66 67 INTEGER, PUBLIC, DIMENSION(2) :: noce_array !: unused array but seems to be needed to prevent agrif from creating an empty module 67 68 69 !! Shallow Water Eq. case (SWE) 70 LOGICAL, PUBLIC :: lk_SWE = .FALSE. !: shallow water flag =T in SWE configurations only 71 72 !! Stand-Alone Surface module (SAS) 73 LOGICAL, PUBLIC :: l_SAS = .FALSE. !: SAS flag =T in SAS configurations only 74 75 68 76 !!---------------------------------------------------------------------- 69 77 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 112 120 END FUNCTION oce_alloc 113 121 122 123 INTEGER FUNCTION oce_SWE_alloc() 124 !!---------------------------------------------------------------------- 125 !! *** FUNCTION oce_SWE_alloc *** 126 !!---------------------------------------------------------------------- 127 INTEGER :: ierr(2) 128 !!---------------------------------------------------------------------- 129 ! 130 lk_SWE = .TRUE. ! =T SWE case 131 ! 132 ierr(:) = 0 133 ALLOCATE( uu(jpi,jpj,jpk,jpt) , vv (jpi,jpj,jpk,jpt) , & 134 & ww(jpi,jpj,jpk) , hdiv(jpi,jpj,jpk) , ssh(jpi,jpj,jpt) , STAT=ierr(1) ) 135 ! 136 ALLOCATE( ts(jpi,jpj,jpk,jpts,jpt) , fraqsr_1lev(jpi,jpj) , & 137 & uu_b(jpi,jpj,jpt) , vv_b(jpi,jpj,jpt) , rn2(jpi,jpj,jpk) , STAT=ierr(2) ) 138 ! 139 oce_SWE_alloc = MAXVAL( ierr ) 140 IF( oce_SWE_alloc /= 0 ) CALL ctl_stop( 'STOP', 'oce_SWE_alloc: failed to allocate arrays' ) 141 ! 142 END FUNCTION oce_SWE_alloc 143 114 144 !!====================================================================== 115 145 END MODULE oce -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/step.F90
r14037 r14062 42 42 !!---------------------------------------------------------------------- 43 43 USE step_oce ! time stepping definition modules 44 !45 USE iom ! xIOs server46 44 47 45 IMPLICIT NONE -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/step_oce.F90
r14037 r14062 3 3 !! *** MODULE step_oce *** 4 4 !! Ocean time-stepping : module used in both initialisation phase and time stepping 5 !! (i.e. nemo_init and stp or stp_MLF routines) 5 6 !!====================================================================== 6 7 !! History : 3.3 ! 2010-08 (C. Ethe) Original code - reorganisation of the initial phase … … 9 10 USE oce ! ocean dynamics and tracers variables 10 11 USE dom_oce ! ocean space and time domain variables 11 USE domain, ONLY : dom_tile 12 USE zdf_oce ! ocean vertical physics variables 13 USE zdfdrg , ONLY : ln_drgimp ! implicit top/bottom friction 12 USE domain , ONLY : dom_tile 14 13 15 14 USE daymod ! calendar (day routine) … … 20 19 USE sbccpl ! surface boundary condition: coupled formulation (call send at end of step) 21 20 USE sbcapr ! surface boundary condition: atmospheric pressure 22 USE tide_mod, ONLY : ln_tide, tide_update23 21 USE sbcwave ! Wave intialisation 22 USE tide_mod ! tides 23 24 USE bdy_oce , ONLY : ln_bdy 25 USE bdydta ! open boundary condition data (bdy_dta routine) 26 USE bdytra ! bdy cond. for tracers (bdy_tra routine) 27 USE bdydyn3d ! bdy cond. for baroclinic vel. (bdy_dyn3d routine) 24 28 25 29 USE isf_oce ! ice shelf boundary condition 26 30 USE isfstp ! ice shelf boundary condition (isf_stp routine) 31 32 USE sshwzv ! vertical velocity and ssh (ssh_nxt routine) 33 ! (ssh_swp routine) 34 ! (wzv routine) 35 USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine) 36 ! (dom_vvl_sf_swp routine) 37 38 USE divhor ! horizontal divergence (div_hor routine) 39 USE dynadv ! advection (dyn_adv routine) 40 USE dynvor ! vorticity term (dyn_vor routine) 41 USE dynhpg ! hydrostatic pressure grad. (dyn_hpg routine) 42 USE dynldf ! lateral momentum diffusion (dyn_ldf routine) 43 USE dynzdf ! vertical diffusion (dyn_zdf routine) 44 USE dynspg ! surface pressure gradient (dyn_spg routine) 45 USE dynatf ! time-filtering (dyn_atf routine) 27 46 28 47 USE traqsr ! solar radiation penetration (tra_qsr routine) … … 40 59 USE eosbn2 ! equation of state (eos_bn2 routine) 41 60 42 USE divhor ! horizontal divergence (div_hor routine)43 USE dynadv ! advection (dyn_adv routine)44 USE dynvor ! vorticity term (dyn_vor routine)45 USE dynhpg ! hydrostatic pressure grad. (dyn_hpg routine)46 USE dynldf ! lateral momentum diffusion (dyn_ldf routine)47 USE dynzdf ! vertical diffusion (dyn_zdf routine)48 USE dynspg ! surface pressure gradient (dyn_spg routine)49 50 USE dynatf ! time-filtering (dyn_atf routine)51 52 61 USE stopar ! Stochastic parametrization (sto_par routine) 53 62 USE stopts 54 55 USE bdy_oce , ONLY : ln_bdy56 USE bdydta ! open boundary condition data (bdy_dta routine)57 USE bdytra ! bdy cond. for tracers (bdy_tra routine)58 USE bdydyn3d ! bdy cond. for baroclinic vel. (bdy_dyn3d routine)59 60 USE sshwzv ! vertical velocity and ssh (ssh_nxt routine)61 ! (ssh_swp routine)62 ! (wzv routine)63 USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine)64 ! (dom_vvl_sf_swp routine)65 63 66 64 USE ldfslp ! iso-neutral slopes (ldf_slp routine) … … 68 66 USE ldftra ! lateral eddy diffusive coef. (ldf_tra routine) 69 67 68 USE zdf_oce ! ocean vertical physics variables 70 69 USE zdfphy ! vertical physics manager (zdf_phy_init routine) 71 USE zdfosm , ONLY : osm_rst, dyn_osm, tra_osm ! OSMOSIS routines used in step.F90 70 USE zdfdrg , ONLY : ln_drgimp ! implicit top/bottom friction 71 USE zdfosm , ONLY : osm_rst, dyn_osm, tra_osm ! OSMOSIS routines used in step.F90 72 72 USE zdfmfc ! Mass FLux Convection routine used in step.F90 73 73 … … 83 83 USE diahth ! thermocline depth (dia_hth routine) 84 84 USE diahsb ! heat, salt and volume budgets (dia_hsb routine) 85 USE diacfl 86 USE diaobs ! Observation operator 85 USE diacfl ! CFL diagnostics (dia_cfl routine) 86 USE diaobs ! Observation operator (dia_obs routine) 87 87 USE diadetide ! Weights computation for daily detiding of model diagnostics 88 88 USE diamlr ! IOM context management for multiple-linear-regression analysis … … 94 94 USE asminc ! assimilation increments (tra_asm_inc routine) 95 95 ! (dyn_asm_inc routine) 96 USE asmbkg 96 USE asmbkg ! writing out state trajectory 97 97 USE stpctl ! time stepping control (stp_ctl routine) 98 98 USE restart ! ocean restart (rst_wri routine) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/stpctl.F90
r14037 r14062 26 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 27 27 USE lib_mpp ! distributed memory computing 28 !29 28 USE netcdf ! NetCDF library 29 30 30 IMPLICIT NONE 31 31 PRIVATE … … 71 71 CHARACTER(len=20) :: clname 72 72 !!---------------------------------------------------------------------- 73 ! 73 74 IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid 74 75 ! … … 179 180 END DO 180 181 IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) 181 END 182 ENDIF 182 183 ! !== error handling ==! 183 184 ! !== done by all processes at every time step ==! -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OFF/dtadyn.F90
r14037 r14062 23 23 USE c1d ! 1D configuration: lk_c1d 24 24 USE dom_oce ! ocean domain: variables 25 #if !defined key_qco26 USE dom vvl! variable volume25 #if defined key_qco 26 USE domqco ! variable volume 27 27 #else 28 USE dom qco28 USE domvvl 29 29 #endif 30 30 USE zdf_oce ! ocean vertical physics: variables … … 97 97 !! * Substitutions 98 98 # include "do_loop_substitute.h90" 99 # include "domzgr_substitute.h90" 100 99 101 !!---------------------------------------------------------------------- 100 102 !! NEMO/OFF 4.0 , NEMO Consortium (2018) … … 388 390 gdepw(:,:,:,Kbb) = gdepw(:,:,:,Kmm) 389 391 ! 390 ENDIF391 392 #endif 393 ENDIF 392 394 ! 393 395 IF( ln_dynrnf .AND. ln_dynrnf_depth ) THEN ! read depht over which runoffs are distributed … … 412 414 ENDIF 413 415 END_2D 416 ! 414 417 DO_2D( 1, 1, 1, 1 ) ! set the associated depth 415 418 h_rnf(ji,jj) = 0._wp -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OFF/nemogcm.F90
r14037 r14062 64 64 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 65 65 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 66 USE step, ONLY : Nbb, Nnn, Naa, Nrhs ! time level indices 66 #if defined key_qco 67 USE stpmlf , ONLY : Nbb, Nnn, Naa, Nrhs ! time level indices 68 #else 69 USE step , ONLY : Nbb, Nnn, Naa, Nrhs ! time level indices 70 #endif 67 71 USE halo_mng 68 72 … … 143 147 CALL dta_dyn_atf( istp, Nbb, Nnn, Naa ) ! time filter of sea surface height and vertical scale factors 144 148 # if defined key_qco 145 CALL dom_qco_r3c( ssh(:,:, Kmm), r3t_f, r3u_f, r3v_f )149 CALL dom_qco_r3c( ssh(:,:,Nnn), r3t_f, r3u_f, r3v_f ) 146 150 # endif 147 151 ENDIF 148 152 CALL trc_stp ( istp, Nbb, Nnn, Nrhs, Naa ) ! time-stepping 149 153 # if defined key_qco 150 !r3t(:,:, Kmm) = r3t_f(:,:) ! update ssh to h0 ratio151 !r3u(:,:, Kmm) = r3u_f(:,:)152 !r3v(:,:, Kmm) = r3v_f(:,:)154 !r3t(:,:,Nnn) = r3t_f(:,:) ! update ssh to h0 ratio 155 !r3u(:,:,Nnn) = r3u_f(:,:) 156 !r3v(:,:,Nnn) = r3v_f(:,:) 153 157 # endif 154 158 #endif … … 160 164 ! 161 165 #if ! defined key_qco 162 # if ! defined key_sed_off166 # if ! defined key_sed_off 163 167 IF( .NOT.ln_linssh ) CALL dta_dyn_sf_interp( istp, Nnn ) ! calculate now grid parameters 164 # endif168 # endif 165 169 #endif 166 170 CALL stp_ctl ( istp ) ! Time loop: control and print -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/SAS/nemogcm.F90
r14044 r14062 216 216 !!---------------------------------------------------------------------- 217 217 ! 218 IF( lk_oasis ) THEN ; cxios_context = 'sas' 219 ELSE ; cxios_context = 'nemo' 218 IF( lk_oasis ) THEN ; cxios_context = 'sas' ! when coupling SAS to OCE 219 ELSE ; cxios_context = 'nemo' ! 220 220 ENDIF 221 221 nn_hls = 1 222 ! 223 l_SAS = .TRUE. ! used in domain:dom_nam 222 224 ! 223 225 ! !-------------------------------------------------! -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/SWE/domzgr_substitute.h90
r12983 r14062 16 16 # define e3v(i,j,k,t) (e3v_0(i,j,k)*(1._wp+r3v(i,j,t))) 17 17 # define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j))) 18 # define e3f_vor(i,j,k) (e3f_0vor(i,j,k)*(1._wp+r3f(i,j))) 18 19 # define e3w(i,j,k,t) (e3w_0(i,j,k)*(1._wp+r3t(i,j,t))) 19 20 # define e3uw(i,j,k,t) (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t))) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/SWE/nemogcm.F90
r14037 r14062 4 4 !! Ocean system : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice) 5 5 !!====================================================================== 6 !! History : OPA ! 1990-10 (C. Levy, G. Madec) Original code 7 !! 7.0 ! 1991-11 (M. Imbard, C. Levy, G. Madec) 8 !! 7.1 ! 1993-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, 9 !! P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1 10 !! - ! 1992-06 (L.Terray) coupling implementation 11 !! - ! 1993-11 (M.A. Filiberti) IGLOO sea-ice 12 !! 8.0 ! 1996-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, 13 !! P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0 14 !! 8.1 ! 1997-06 (M. Imbard, G. Madec) 15 !! 8.2 ! 1999-11 (M. Imbard, H. Goosse) sea-ice model 16 !! ! 1999-12 (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols) OPEN-MP 17 !! ! 2000-07 (J-M Molines, M. Imbard) Open Boundary Conditions (CLIPPER) 18 !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and modules 19 !! - ! 2004-06 (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces 20 !! - ! 2004-08 (C. Talandier) New trends organization 21 !! - ! 2005-06 (C. Ethe) Add the 1D configuration possibility 22 !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization 23 !! - ! 2006-03 (L. Debreu, C. Mazauric) Agrif implementation 24 !! - ! 2006-04 (G. Madec, R. Benshila) Step reorganization 25 !! - ! 2007-07 (J. Chanut, A. Sellar) Unstructured open boundaries (BDY) 26 !! 3.2 ! 2009-08 (S. Masson) open/write in the listing file in mpp 27 !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 28 !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 29 !! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation 30 !! - ! 2011-11 (C. Harris) decomposition changes for running with CICE 31 !! 3.6 ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening 32 !! - ! 2014-12 (G. Madec) remove KPP scheme and cross-land advection (cla) 33 !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface 6 !! History : 4.0 ! 2020-05 (A. Nasser, G. Madec) Original code from 4.0.2 7 !! - ! 2020-10 (S. Techene, G. Madec) cleanning 34 8 !!---------------------------------------------------------------------- 35 9 … … 42 16 !!---------------------------------------------------------------------- 43 17 USE step_oce ! module used in the ocean time stepping module (step.F90) 18 ! 44 19 USE phycst ! physical constant (par_cst routine) 45 20 USE domain ! domain initialization (dom_init & dom_cfg routines) 46 USE closea ! treatment of closed seas (for ln_closea)47 21 USE usrdef_nam ! user defined configuration 48 USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine)49 USE bdy_oce, ONLY : ln_bdy50 22 USE bdyini ! open boundary cond. setting (bdy_init routine) 51 23 USE istate ! initial state setting (istate_init routine) 52 USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine) 53 USE ldftra ! lateral diffusivity setting (ldftra_init routine) 54 USE trdini ! dyn/tra trends initialization (trd_init routine) 55 USE asminc ! assimilation increments 56 USE asmbkg ! writing out state trajectory 57 USE diaptr ! poleward transports (dia_ptr_init routine) 58 USE diadct ! sections transports (dia_dct_init routine) 59 USE diaobs ! Observation diagnostics (dia_obs_init routine) 60 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 61 USE diamlr ! IOM context management for multiple-linear-regression analysis 24 USE trd_oce , ONLY : l_trddyn ! dynamical trend logical 62 25 #if defined key_RK3 63 USE stpRK3 64 #elif defined key_qco 65 USE stpLF 26 USE stprk3 ! NEMO time-stepping (stp_RK3 routine) 66 27 #else 67 USE step ! NEMO time-stepping (stp routine) 68 #endif 69 USE isfstp ! ice shelf (isf_stp_init routine) 70 USE icbini ! handle bergs, initialisation 71 USE icbstp ! handle bergs, calving, themodynamics and transport 72 USE cpl_oasis3 ! OASIS3 coupling 73 USE c1d ! 1D configuration 74 USE step_c1d ! Time stepping loop for the 1D configuration 75 USE dyndmp ! Momentum damping 76 USE stopar ! Stochastic param.: ??? 77 USE stopts ! Stochastic param.: ??? 78 USE diu_layers ! diurnal bulk SST and coolskin 79 USE crsini ! initialise grid coarsening utility 80 USE dia25h ! 25h mean output 81 USE diadetide ! Weights computation for daily detiding of model diagnostics 82 USE sbc_oce , ONLY : lk_oasis 83 USE wet_dry ! Wetting and drying setting (wad_init routine) 84 #if defined key_top 85 USE trcini ! passive tracer initialisation 86 #endif 87 #if defined key_nemocice_decomp 88 USE ice_domain_size, only: nx_global, ny_global 28 USE stpmlf ! NEMO time-stepping (stp_MLF routine) 89 29 #endif 90 30 ! 91 31 USE lib_mpp ! distributed memory computing 92 32 USE mppini ! shared/distributed memory setting (mpp_init routine) 93 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges33 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 94 34 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 95 #if defined key_iomput 96 USE xios ! xIOserver 97 #endif 98 #if defined key_agrif 99 USE agrif_all_update ! Master Agrif update 100 #endif 35 USE halo_mng ! Halo manager 101 36 102 37 IMPLICIT NONE … … 139 74 !!---------------------------------------------------------------------- 140 75 ! 141 #if defined key_agrif142 CALL Agrif_Init_Grids() ! AGRIF: set the meshes143 #endif144 76 ! !-----------------------! 145 77 CALL nemo_init !== Initialisations ==! 146 78 ! !-----------------------! 147 148 #if defined key_agrif149 Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices150 CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM151 CALL Agrif_Declare_Var ! " " " " " DYN/TRA152 # if defined key_top153 CALL Agrif_Declare_Var_top ! " " " " " TOP154 # endif155 # if defined key_si3156 CALL Agrif_Declare_Var_ice ! " " " " " Sea ice157 # endif158 #endif159 79 ! check that all process are still there... If some process have an error, 160 80 ! they will never enter in step and other processes will wait until the end of the cpu time! 81 ! 82 ! ! SWE case: only with key_qco 83 #if ! defined key_qco 84 CALL ctl_stop( 'nemo_gcm (SWE): shallow water model requires key_qco' ) 85 #endif 86 ! 161 87 CALL mpp_max( 'nemogcm', nstop ) 162 88 … … 174 100 ! 175 101 DO WHILE( istp <= nitend .AND. nstop == 0 ) 176 102 ! 177 103 ncom_stp = istp 178 104 IF( ln_timing ) THEN … … 181 107 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 182 108 ENDIF 109 ! 183 110 #if defined key_RK3 184 111 CALL stp_RK3 ( istp ) 185 #elif defined key_qco186 CALL stp_LF ( istp )187 112 #else 188 CALL stp 113 CALL stp_MLF ( istp ) 189 114 #endif 190 115 istp = istp + 1 191 116 ! 192 117 IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 193 118 ! 194 119 END DO 195 120 ! … … 232 157 INTEGER :: ios, ilocal_comm ! local integers 233 158 !! 234 NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, & 235 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 236 & ln_timing, ln_diacfl 159 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, nn_isplt, nn_jsplt , nn_ictls, & 160 & nn_ictle, nn_jctls , nn_jctle 237 161 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 238 162 !!---------------------------------------------------------------------- … … 246 170 ! 247 171 #if defined key_iomput 248 IF( Agrif_Root() ) THEN 249 IF( lk_oasis ) THEN 250 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 251 CALL xios_initialize( "not used" , local_comm =ilocal_comm ) ! send nemo communicator to xios 252 ELSE 253 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios 254 ENDIF 255 ENDIF 172 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios 256 173 CALL mpp_start( ilocal_comm ) 257 174 #else 258 IF( lk_oasis ) THEN 259 IF( Agrif_Root() ) THEN 260 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 261 ENDIF 262 CALL mpp_start( ilocal_comm ) 263 ELSE 264 CALL mpp_start( ) 265 ENDIF 175 CALL mpp_start( ) 266 176 #endif 267 177 ! … … 292 202 ! 293 203 ! finalize the definition of namctl variables 294 IF( sn_cfctl%l_allon ) THEN 295 ! Turn on all options. 296 CALL nemo_set_cfctl( sn_cfctl, .TRUE., .TRUE. ) 297 ! Ensure all processors are active 298 sn_cfctl%procmin = 0 ; sn_cfctl%procmax = 1000000 ; sn_cfctl%procincr = 1 299 ELSEIF( sn_cfctl%l_config ) THEN 300 ! Activate finer control of report outputs 301 ! optionally switch off output from selected areas (note this only 302 ! applies to output which does not involve global communications) 303 IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. & 304 & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) & 305 & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. ) 306 ELSE 307 ! turn off all options. 308 CALL nemo_set_cfctl( sn_cfctl, .FALSE., .TRUE. ) 309 ENDIF 204 IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) & 205 & CALL nemo_set_cfctl( sn_cfctl, .FALSE. ) 310 206 ! 311 207 lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print … … 336 232 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 337 233 WRITE(numout,*) 234 235 ! Print the working precision to ocean.output 236 IF (wp == dp) THEN 237 WRITE(numout,*) "Working precision = double-precision" 238 ELSE 239 WRITE(numout,*) "Working precision = single-precision" 240 ENDIF 241 WRITE(numout,*) 338 242 ! 339 243 WRITE(numout,cform_aaa) ! Flag AAAAAAA … … 353 257 ! 354 258 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 355 CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )259 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 356 260 ELSE ! user-defined namelist 357 CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )261 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 358 262 ENDIF 359 263 ! … … 365 269 CALL mpp_init 366 270 271 CALL halo_mng_init() 367 272 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 368 273 CALL nemo_alloc() 369 274 370 275 ! Initialise time level indices 371 Nbb = 1 ; Nnn = 2; Naa = 3;Nrhs = Naa372 276 Nbb = 1 ; Nnn = 2 ; Naa = 3 ; Nrhs = Naa 277 373 278 ! !-------------------------------! 374 279 ! ! NEMO general initialization ! … … 382 287 ! 383 288 CALL phy_cst ! Physical constants 384 289 ! 290 ! ! SWE: Set rho0 and associated variables (eosbn2 not used) 291 rho0 = 1026._wp !: volumic mass of reference [kg/m3] 292 rcp = 3991.86795711963_wp !: heat capacity [J/K] 293 rho0_rcp = rho0 * rcp 294 r1_rho0 = 1._wp / rho0 295 r1_rcp = 1._wp / rcp 296 r1_rho0_rcp = 1._wp / rho0_rcp 297 ! 385 298 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 386 299 … … 391 304 392 305 ! ! external forcing 393 CALL tide_init ! tidal harmonics394 395 306 CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice) 396 397 307 398 308 ! ! Ocean physics … … 400 310 CALL ldf_dyn_init ! Lateral ocean momentum physics 401 311 402 403 312 ! ! Dynamics 404 313 CALL dyn_adv_init ! advection (vector or flux form) 405 406 314 CALL dyn_vor_init ! vorticity term including Coriolis 407 408 315 CALL dyn_ldf_init ! lateral mixing 409 316 410 CALL dyn_spg_init ! surface pressure gradient411 412 317 ! ! Diagnostics 413 CALL flo_init( Nnn ) ! drifting Floats414 415 318 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 416 417 CALL trd_init( Nnn ) ! Mixed-layer/Vorticity/Integral constraints trends 418 319 ! ! Trends diag: switched off 320 l_trddyn = .FALSE. ! No trend diagnostics 419 321 420 322 IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA … … 422 324 IF( ln_timing ) CALL timing_stop( 'nemo_init') 423 325 ! 424 425 326 END SUBROUTINE nemo_init 426 327 … … 440 341 WRITE(numout,*) '~~~~~~~~' 441 342 WRITE(numout,*) ' Namelist namctl' 442 WRITE(numout,*) ' sn_cfctl%l_glochk = ', sn_cfctl%l_glochk443 WRITE(numout,*) ' sn_cfctl%l_allon = ', sn_cfctl%l_allon444 WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config445 343 WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat 446 344 WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat … … 454 352 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 455 353 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 456 WRITE(numout,*) ' level of print nn_print = ', nn_print457 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls458 WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle459 WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls460 WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle461 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt462 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt463 354 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 464 355 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 465 356 ENDIF 466 357 ! 467 nprint = nn_print ! convert DOCTOR namelist names into OLD names 468 nictls = nn_ictls 469 nictle = nn_ictle 470 njctls = nn_jctls 471 njctle = nn_jctle 472 isplt = nn_isplt 473 jsplt = nn_jsplt 474 358 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file 475 359 IF(lwp) THEN ! control print 476 360 WRITE(numout,*) … … 482 366 WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out) 483 367 WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 484 ENDIF485 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file486 !487 ! ! Parameter control488 !489 IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints490 IF( lk_mpp .AND. jpnij > 1 ) THEN491 isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain492 ELSE493 IF( isplt == 1 .AND. jsplt == 1 ) THEN494 CALL ctl_warn( ' - isplt & jsplt are equal to 1', &495 & ' - the print control will be done over the whole domain' )496 ENDIF497 ijsplt = isplt * jsplt ! total number of processors ijsplt498 ENDIF499 IF(lwp) WRITE(numout,*)' - The total number of processors over which the'500 IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt501 !502 ! ! indices used for the SUM control503 IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area504 lsp_area = .FALSE.505 ELSE ! print control done over a specific area506 lsp_area = .TRUE.507 IF( nictls < 1 .OR. nictls > jpiglo ) THEN508 CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )509 nictls = 1510 ENDIF511 IF( nictle < 1 .OR. nictle > jpiglo ) THEN512 CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )513 nictle = jpiglo514 ENDIF515 IF( njctls < 1 .OR. njctls > jpjglo ) THEN516 CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )517 njctls = 1518 ENDIF519 IF( njctle < 1 .OR. njctle > jpjglo ) THEN520 CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )521 njctle = jpjglo522 ENDIF523 ENDIF524 368 ENDIF 525 369 ! … … 571 415 USE diawri , ONLY : dia_wri_alloc 572 416 USE dom_oce , ONLY : dom_oce_alloc 573 USE trc_oce , ONLY : trc_oce_alloc574 USE bdy_oce , ONLY : bdy_oce_alloc575 417 ! 576 418 INTEGER :: ierr 577 419 !!---------------------------------------------------------------------- 578 420 ! 579 ierr = oce_ alloc() ! ocean421 ierr = oce_SWE_alloc() ! ocean 580 422 ierr = ierr + dia_wri_alloc() 581 423 ierr = ierr + dom_oce_alloc() ! ocean domain 582 424 ierr = ierr + zdf_oce_alloc() ! ocean vertical physics 583 ierr = ierr + trc_oce_alloc() ! shared TRC / TRA arrays584 ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization)585 425 ! 586 426 CALL mpp_sum( 'nemogcm', ierr ) … … 590 430 591 431 592 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto , for_all)432 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto ) 593 433 !!---------------------------------------------------------------------- 594 434 !! *** ROUTINE nemo_set_cfctl *** 595 435 !! 596 436 !! ** Purpose : Set elements of the output control structure to setto. 597 !! for_all should be .false. unless all areas are to be598 !! treated identically.599 437 !! 600 438 !! ** Method : Note this routine can be used to switch on/off some 601 !! types of output for selected areas but any output types 602 !! that involve global communications (e.g. mpp_max, glob_sum) 603 !! should be protected from selective switching by the 604 !! for_all argument 605 !!---------------------------------------------------------------------- 606 LOGICAL :: setto, for_all 607 TYPE(sn_ctl) :: sn_cfctl 608 !!---------------------------------------------------------------------- 609 IF( for_all ) THEN 610 sn_cfctl%l_runstat = setto 611 sn_cfctl%l_trcstat = setto 612 ENDIF 439 !! types of output for selected areas. 440 !!---------------------------------------------------------------------- 441 TYPE(sn_ctl), INTENT(inout) :: sn_cfctl 442 LOGICAL , INTENT(in ) :: setto 443 !!---------------------------------------------------------------------- 444 sn_cfctl%l_runstat = setto 445 sn_cfctl%l_trcstat = setto 613 446 sn_cfctl%l_oceout = setto 614 447 sn_cfctl%l_layout = setto … … 620 453 !!====================================================================== 621 454 END MODULE nemogcm 622 -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/SWE/stpctl.F90
r14037 r14062 3 3 !! *** MODULE stpctl *** 4 4 !! Ocean run control : gross check of the ocean time stepping 5 !! *** Shallow Water Equation (SWE) case *** 6 !! ( No test on temperature and salinity ) 5 7 !!====================================================================== 6 !! History : OPA ! 1991-03 (G. Madec) Original code 7 !! 6.0 ! 1992-06 (M. Imbard) 8 !! 8.0 ! 1997-06 (A.M. Treguier) 9 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 10 !! 2.0 ! 2009-07 (G. Madec) Add statistic for time-spliting 11 !! 3.7 ! 2016-09 (G. Madec) Remove solver 12 !! 4.0 ! 2017-04 (G. Madec) regroup global communications 8 !! History : SWE ! 2020-09 (A. Nasser, S. Techene ) OCE/stpctl adaptated to SWE 13 9 !!---------------------------------------------------------------------- 14 10 … … 21 17 USE zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables 22 18 USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy 23 ! 19 ! 24 20 USE diawri ! Standard run outputs (dia_wri_state routine) 25 21 USE in_out_manager ! I/O manager 26 22 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 27 23 USE lib_mpp ! distributed memory computing 28 !29 24 USE netcdf ! NetCDF library 25 30 26 IMPLICIT NONE 31 27 PRIVATE … … 35 31 INTEGER :: nrunid ! netcdf file id 36 32 INTEGER, DIMENSION(2) :: nvarid ! netcdf variable id 33 34 # include "domzgr_substitute.h90" 37 35 !!---------------------------------------------------------------------- 38 36 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 49 47 !! 50 48 !! ** Method : - Save the time step in numstp 49 !! - Print it each 50 time steps 51 50 !! - Stop the run IF problem encountered by setting nstop > 0 52 !! Problems checked: negative sea surface height51 !! Problems checked: e3t0+ssh minimum smaller that 0 53 52 !! |U| maximum larger than 10 m/s 53 !! ( not for SWE : negative sea surface salinity ) 54 54 !! 55 55 !! ** Actions : "time.step" file = last ocean time-step … … 63 63 INTEGER :: idtime, istatus 64 64 INTEGER , DIMENSION(3) :: iareasum, iareamin, iareamax 65 INTEGER , DIMENSION(3, 2) :: iloc ! min/max loc indices65 INTEGER , DIMENSION(3,4) :: iloc ! min/max loc indices 66 66 REAL(wp) :: zzz ! local real 67 67 REAL(wp), DIMENSION(3) :: zmax, zmaxlocal … … 70 70 CHARACTER(len=20) :: clname 71 71 !!---------------------------------------------------------------------- 72 IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid 73 ! 72 74 IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid 73 75 ! … … 109 111 ! !== test of local extrema ==! 110 112 ! !== done by all processes at every time step ==! 111 !112 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region113 llmsk(Nie1: jpi,:,:) = .FALSE.114 llmsk(:, 1:Njs1,:) = .FALSE.115 llmsk(:,Nje1: jpj,:) = .FALSE.116 ! 113 zmax(1) = MINVAL( e3t_0(:,:,1)+ssh(:,:,Kmm) ) ! e3t_Kmm min 114 llmsk(:,:,:) = umask(:,:,:) == 1._wp 115 zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only) 116 zmax(3) = REAL( nstop , wp ) ! stop indicator 117 ! !== get global extrema ==! 118 ! !== done by all processes if writting run.stat ==! 117 119 llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain 118 120 zmax(1) = MAXVAL( -e3t(:,:,1,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max … … 131 133 IF( ll_wrtruns ) THEN 132 134 WRITE(numrun,9500) kt, zmax(1), zmax(2) 133 istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ -zmax(1)/), (/kt/), (/1/) )134 istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ 135 istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) ) 136 istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) ) 135 137 IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) 136 END 138 ENDIF 137 139 ! !== error handling ==! 138 140 ! !== done by all processes at every time step ==! 139 141 ! 140 IF( zmax(1) > 0._wp .OR. & ! negative sea surface height 141 & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) 142 !!SWE specific : start 143 IF( zmax(1) <= 0._wp .OR. & ! negative e3t_Kmm 144 & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) 142 145 & ISNAN( zmax(1) + zmax(2) ) .OR. & ! NaN encounter in the tests 143 146 & ABS( zmax(1) + zmax(2) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests … … 148 151 IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) 149 152 ! get global loc on the min/max 150 llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain 151 CALL mpp_maxloc( 'stpctl', -e3t(:,:,1,Kmm) , llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 152 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 153 CALL mpp_maxloc( 'stpctl', ABS(uu(:,:,:,Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) 153 CALL mpp_minloc( 'stpctl', e3t_0(:,:,1) + ssh(:,:,Kmm), ssmask(:,: ), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 154 CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,Kmm)) , umask(:,:,:), zzz, iloc(1:3,2) ) 154 155 ! find which subdomain has the max. 155 156 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 … … 164 165 ELSE ! find local min and max locations: 165 166 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 166 llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain 167 iloc(1:2,1) = MAXLOC( -e3t(:,:,1,Kmm) , mask = llmsk(:,:,1) ) 168 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 169 iloc(1:3,2) = MAXLOC( ABS(uu(:,:,:,Kmm)), mask = llmsk(:,:,:) ) 170 DO ji = 1, 2 ! local domain indices ==> global domain indices, excluding halos 171 iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 172 END DO 167 iloc(1:2,1) = MINLOC( e3t_0(:,:,1) + ssh(:,:,Kmm), mask = ssmask(:,: ) == 1._wp ) + (/ nimpp - 1, njmpp - 1 /) 168 iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = umask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 173 169 iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information 174 170 ENDIF 175 171 ! 176 WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100or NaN encounter in the tests'177 CALL wrt_line( ctmp2, kt, ' |e3t| min', -zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) )178 CALL wrt_line( ctmp3, kt, '|U| max' , zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) )172 WRITE(ctmp1,*) ' stp_ctl: e3t0+ssh < 0 m or |U| > 10 m/s or NaN encounter in the tests' 173 CALL wrt_line( ctmp2, kt, 'e3t0+ssh min', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 174 CALL wrt_line( ctmp3, kt, '|U| max' , zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 179 175 IF( Agrif_Root() ) THEN 180 176 WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' … … 194 190 ! 195 191 ENDIF 192 !!SWE specific : end 196 193 ! 197 194 IF( nstop > 0 ) THEN ! an error was detected and we did not abort yet... … … 200 197 ENDIF 201 198 ! 202 9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16)199 9500 FORMAT(' it :', i8, ' e3t_min: ', D23.16, ' |U|_max: ', D23.16) 203 200 ! 204 201 END SUBROUTINE stp_ctl -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/TOP/PISCES/SED/oce_sed.F90
r13237 r14062 13 13 USE dom_oce , ONLY : glamt => glamt !: longitude of t-point (degre) 14 14 USE dom_oce , ONLY : gphit => gphit !: latitude of t-point (degre) 15 !!st15 16 16 #if ! defined key_qco 17 17 USE dom_oce , ONLY : e3t => e3t !: latitude of t-point (degre) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/TOP/TRP/trcatf.F90
r13295 r14062 32 32 USE trdtra 33 33 # if defined key_qco 34 USE traatf qco34 USE traatf_qco 35 35 # else 36 36 USE traatf -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/BENCH/EXPREF/namelist_cfg_orca025_like
r14037 r14062 178 178 !----------------------------------------------------------------------- 179 179 ln_dynvor_een = .true. ! energy & enstrophy scheme 180 nn_een_e3f = 0! =0 e3f = mi(mj(e3t))/4181 !! =1 e3f = mi(mj(e3t))/mi(mj( tmask))180 nn_e3f_typ = 0 ! =0 e3f = mi(mj(e3t))/4 181 ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) 182 182 / 183 183 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/BENCH/EXPREF/namelist_cfg_orca12_like
r14037 r14062 177 177 !----------------------------------------------------------------------- 178 178 ln_dynvor_een = .true. ! energy & enstrophy scheme 179 nn_e en_e3f= 0 ! =0 e3f = mi(mj(e3t))/4179 nn_e3f_typ = 0 ! =0 e3f = mi(mj(e3t))/4 180 180 ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) 181 181 / -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/BENCH/MY_SRC/usrdef_istate.F90
r13295 r14062 26 26 PRIVATE 27 27 28 PUBLIC usr_def_istate ! called by istate.F90 28 PUBLIC usr_def_istate ! called by istate.F90 29 PUBLIC usr_def_istate_ssh ! called by domqco.F90 29 30 30 31 !! * Substitutions … … 37 38 CONTAINS 38 39 39 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh )40 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) !!st, pssh ) 40 41 !!---------------------------------------------------------------------- 41 42 !! *** ROUTINE usr_def_istate *** … … 52 53 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 53 54 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 54 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height55 !!st REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height 55 56 ! 56 57 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace … … 79 80 ! 80 81 ! sea level: 81 pssh(:,:) = z2d(:,:) ! +/- 0.05 m82 !!st pssh(:,:) = z2d(:,:) ! +/- 0.05 m 82 83 ! 83 84 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) … … 95 96 pv( :,:,jpk ) = 0._wp 96 97 ! 97 CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions98 !!st CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions 98 99 CALL lbc_lnk('usrdef_istate', pts, 'T', 1. ) ! apply boundary conditions 99 100 CALL lbc_lnk('usrdef_istate', pu, 'U', -1. ) ! apply boundary conditions … … 102 103 END SUBROUTINE usr_def_istate 103 104 105 106 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 107 !!---------------------------------------------------------------------- 108 !! *** ROUTINE usr_def_istate_ssh *** 109 !! 110 !! ** Purpose : Initialization of ssh 111 !! Here BENCH configuration 112 !! 113 !! ** Method : Set ssh 114 !!---------------------------------------------------------------------- 115 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 116 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 117 ! 118 INTEGER :: ji, jj 119 INTEGER :: igloi, igloj ! to be removed in the future, see usr_def_istate comment 120 !!---------------------------------------------------------------------- 121 ! 122 IF(lwp) WRITE(numout,*) 123 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : BENCH configuration, analytical definition of initial ssh' 124 ! 125 igloi = Ni0glo + 2 * COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) ) 126 igloj = Nj0glo + 2 * COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) + 1 * COUNT( (/ jperio >= 4 .AND. jperio <= 6 /) ) 127 ! sea level: +/- 0.05 m 128 DO_2D( 0, 0, 0, 0 ) 129 pssh(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * igloi, wp ) / REAL( igloi * igloj, wp ) ) 130 END_2D 131 ! 132 CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions 133 ! 134 END SUBROUTINE usr_def_istate_ssh 135 104 136 !!====================================================================== 105 137 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/CANAL/EXPREF/namelist_cfg
r14037 r14062 235 235 ln_dynvor_mix = .false. ! mixed scheme 236 236 ln_dynvor_een = .false. ! energy & enstrophy scheme 237 ln_dynvor_enT = .false. ! energy conserving scheme (T-point)237 r_enT = .false. ! energy conserving scheme (T-point) 238 238 ln_dynvor_eeT = .true. ! energy conserving scheme (een using e3t) 239 nn_e en_e3f= 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)239 nn_e3f_typ = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 240 240 / 241 241 !----------------------------------------------------------------------- … … 319 319 !! namdiu Cool skin and warm layer models (default: OFF) 320 320 !! namdiu Cool skin and warm layer models (default: OFF) 321 <<<<<<< .working322 !! namflo float parameters (default: OFF)323 !! nam_diadct transports through some sections (default: OFF)324 ||||||| .merge-left.r13465325 !! namflo float parameters (default: OFF)326 !! nam_diaharm Harmonic analysis of tidal constituents (default: OFF)327 !! nam_diadct transports through some sections (default: OFF)328 =======329 321 !! namflo float parameters ("key_float") 330 322 !! nam_diaharm Harmonic analysis of tidal constituents ("key_diaharm") 331 323 !! namdct transports through some sections ("key_diadct") 332 324 !! nam_diatmb Top Middle Bottom Output (default: OFF) 333 >>>>>>> .merge-right.r13470334 325 !! nam_dia25h 25h Mean Output (default: OFF) 335 326 !! namnc4 netcdf4 chunking and compression settings ("key_netcdf4") -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/CANAL/MY_SRC/usrdef_istate.F90
r14037 r14062 26 26 PRIVATE 27 27 28 PUBLIC usr_def_istate ! called by istate.F90 28 PUBLIC usr_def_istate ! called by istate.F90 29 PUBLIC usr_def_istate_ssh ! called by sshwzv.F90 29 30 30 31 !! * Substitutions … … 37 38 CONTAINS 38 39 39 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)40 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 40 41 !!---------------------------------------------------------------------- 41 42 !! *** ROUTINE usr_def_istate *** … … 52 53 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 53 54 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 54 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height55 55 ! 56 56 INTEGER :: ji, jj, jk, jl ! dummy loop indices … … 87 87 88 88 CASE(0) ! rest 89 90 ! sea level: 91 pssh(:,:) = 0. 89 ! 92 90 ! temperature: 93 91 pts(:,:,:,jp_tem) = 10._wp … … 99 97 100 98 CASE(1) ! geostrophic zonal jet from -zjety to +zjety 101 102 ! sea level: 103 SELECT CASE( nn_fcase ) 104 CASE(0) ! f = f0 105 ! sea level: ssh = - fuy / g 106 WHERE( ABS(gphit) <= zjety ) 107 pssh(:,:) = - ff_t(:,:) * rn_uzonal * gphit(:,:) * 1.e3 / grav 108 ELSEWHERE 109 pssh(:,:) = - ff_t(:,:) * rn_uzonal * SIGN(zjety, gphit(:,:)) * 1.e3 / grav 110 END WHERE 111 CASE(1) ! f = f0 + beta*y 112 ! sea level: ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 113 zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 114 WHERE( ABS(gphit) <= zjety ) 115 pssh(:,:) = - rn_uzonal / grav * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 116 ELSEWHERE 117 pssh(:,:) = - rn_uzonal / grav * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3 & 118 & + 0.5 * zbeta * zjety * zjety * 1.e6 ) 119 END WHERE 120 END SELECT 99 ! 121 100 ! temperature: 122 101 pts(:,:,:,jp_tem) = 10._wp … … 139 118 ! 140 119 CASE(2) ! geostrophic zonal current shear 141 142 ! sea level: 143 SELECT CASE( nn_fcase ) 144 CASE(0) ! f = f0 145 ! sea level: ssh = - fuy / g 146 WHERE( ABS(gphit) <= zjety ) 147 pssh(:,:) = - ff_t(:,:) * rn_uzonal * ABS(gphit(:,:)) * 1.e3 / grav 148 ELSEWHERE 149 pssh(:,:) = - ff_t(:,:) * rn_uzonal * zjety * 1.e3 / grav 150 END WHERE 151 CASE(1) ! f = f0 + beta*y 152 ! sea level: ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 153 zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 154 WHERE( ABS(gphit) <= zjety ) 155 pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & 156 & * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 157 ELSEWHERE 158 pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & 159 & * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3 + 0.5 * zbeta * zjety * zjety * 1.e6 ) 160 END WHERE 161 END SELECT 120 ! 162 121 ! temperature: 163 122 pts(:,:,:,jp_tem) = 10._wp … … 176 135 ! 177 136 CASE(3) ! gaussian zonal currant 178 137 ! 179 138 ! zonal current 180 139 DO jk=1, jpkm1 … … 182 141 pu(:,:,jk) = rn_uzonal * EXP( - 0.5 * gphit(:,:)**2 / rn_lambda**2 ) 183 142 END DO 184 185 ! sea level:186 pssh(:,1) = - ff_t(:,1) / grav * pu(:,1,1) * e2t(:,1)187 DO jl=1, jpnj188 DO_2D( 0, 0, 0, 0 )189 pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj)190 END_2D191 CALL lbc_lnk( 'usrdef_istate', pssh, 'T', 1. )192 END DO193 194 143 ! temperature: 195 144 pts(:,:,:,jp_tem) = 10._wp … … 202 151 ! 203 152 CASE(4) ! geostrophic zonal pulse 204 153 ! 205 154 DO_2D( 1, 1, 1, 1 ) 206 155 IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN … … 210 159 ELSE 211 160 zdu = 0. 212 END 161 ENDIF 213 162 IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 214 pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav215 163 pu(ji,jj,:) = zdu 216 164 pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1. 217 165 ELSE 218 pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav219 166 pu(ji,jj,:) = 0. 220 167 pts(ji,jj,:,jp_sal) = 1. 221 END 222 END_2D 223 168 ENDIF 169 END_2D 170 ! 224 171 ! temperature: 225 172 pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:) 226 173 pv(:,:,:) = 0. 227 228 229 174 ! 175 CASE(5) ! vortex 176 ! 230 177 zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 231 zumax = rn_vtxmax * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic178 zumax = rn_vtxmax * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 232 179 zlambda = SQRT(2._wp)*rn_lambda*1.e3 ! Horizontal scale in meters 233 180 zn2 = 3.e-3**2 … … 242 189 ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 243 190 zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal * zy 244 ! Sea level:245 pssh(ji,jj) = 0.246 DO jl=1,5247 zdt = pssh(ji,jj)248 zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH)) ! F'(z)249 zrho1 = rho0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y)250 pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1) ! ssh = Psurf / (Rho*g)251 END DO252 191 ! temperature: 253 192 DO jk=1,jpk … … 299 238 ! 300 239 END SELECT 301 240 ! 241 CALL lbc_lnk( 'usrdef_istate', pts , 'T', 1. ) 242 CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) 243 244 END SUBROUTINE usr_def_istate 245 246 247 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 248 !!---------------------------------------------------------------------- 249 !! *** ROUTINE usr_def_istate_ssh *** 250 !! 251 !! ** Purpose : Initialization of the dynamics and tracers 252 !! Here CANAL configuration 253 !! 254 !! ** Method : Set ssh 255 !!---------------------------------------------------------------------- 256 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 257 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height 258 ! 259 INTEGER :: ji, jj, jk, jl ! dummy loop indices 260 REAL(wp) :: zx, zy, zP0, zumax, zlambda, zr_lambda2, zn2, zf0, zH, zrho1, za, zf, zdzF 261 REAL(wp) :: zpsurf, zdyPs, zdxPs 262 REAL(wp) :: zdt, zdu, zdv 263 REAL(wp) :: zjetx, zjety, zbeta 264 REAL(wp), DIMENSION(jpi,jpj) :: zrandom 265 !!---------------------------------------------------------------------- 266 ! 267 IF(lwp) WRITE(numout,*) 268 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : CANAL configuration, analytical definition of initial state' 269 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ ' 270 ! 271 IF (ln_sshnoise) CALL RANDOM_NUMBER(zrandom) 272 zjetx = ABS(rn_ujetszx)/2. 273 zjety = ABS(rn_ujetszy)/2. 274 ! 275 SELECT CASE(nn_initcase) 276 CASE(0) !== rest ==! 277 ! 278 pssh(:,:) = 0. 279 ! 280 CASE(1) !== geostrophic zonal jet from -zjety to +zjety ==! 281 ! 282 SELECT CASE( nn_fcase ) 283 CASE(0) !* f = f0 : ssh = - fuy / g 284 WHERE( ABS(gphit) <= zjety ) 285 pssh(:,:) = - ff_t(:,:) * rn_uzonal * gphit(:,:) * 1.e3 / grav 286 ELSEWHERE 287 pssh(:,:) = - ff_t(:,:) * rn_uzonal * SIGN(zjety, gphit(:,:)) * 1.e3 / grav 288 END WHERE 289 CASE(1) !* f = f0 + beta*y : ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 290 zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 291 WHERE( ABS(gphit) <= zjety ) 292 pssh(:,:) = - rn_uzonal / grav * ( ff_t(:,:) * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 293 ELSEWHERE 294 pssh(:,:) = - rn_uzonal / grav * ( ff_t(:,:) * SIGN(zjety, gphit(:,:)) * 1.e3 & 295 & + 0.5 * zbeta * zjety * zjety * 1.e6 ) 296 END WHERE 297 END SELECT 298 ! 299 CASE(2) !== geostrophic zonal current shear ==! 300 ! 301 SELECT CASE( nn_fcase ) 302 CASE(0) !* f = f0 : ssh = - fuy / g 303 WHERE( ABS(gphit) <= zjety ) 304 pssh(:,:) = - ff_t(:,:) * rn_uzonal * ABS(gphit(:,:)) * 1.e3 / grav 305 ELSEWHERE 306 pssh(:,:) = - ff_t(:,:) * rn_uzonal * zjety * 1.e3 / grav 307 END WHERE 308 CASE(1) !* f = f0 + beta*y : ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 309 zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 310 WHERE( ABS(gphit) <= zjety ) 311 pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & 312 & * ( ff_t(:,:) * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 313 ELSEWHERE 314 pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & 315 & * ( ff_t(:,:) * SIGN(zjety, gphit(:,:)) * 1.e3 + 0.5 * zbeta * zjety * zjety * 1.e6 ) 316 END WHERE 317 END SELECT 318 ! 319 CASE(3) !== gaussian zonal currant ==! 320 ! 321 pssh(:,1) = - ff_t(:,1) / grav * e2t(:,1) * rn_uzonal * EXP( - 0.5 * gphit(:,1)**2 / rn_lambda**2 ) 322 DO jl=1, jpnj 323 DO_2D( 0, 0, 0, 0 ) 324 pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * rn_uzonal * EXP( - 0.5 * gphit(ji,jj)**2 / rn_lambda**2 ) * e2t(ji,jj) 325 END_2D 326 CALL lbc_lnk( 'usrdef_istate_ssh', pssh, 'T', 1. ) 327 END DO 328 ! 329 CASE(4) !== geostrophic zonal pulse !!st need to implement a way to separate ssh properly ==! 330 ! 331 DO_2D( 1, 1, 1, 1 ) 332 IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN 333 zdu = rn_uzonal 334 ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN 335 zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. ) 336 ELSE 337 zdu = 0. 338 ENDIF 339 IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 340 pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav 341 ELSE 342 pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav 343 ENDIF 344 END_2D 345 ! 346 CASE(5) !== vortex ==! 347 ! 348 zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 349 zumax = rn_vtxmax * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 350 zlambda = SQRT(2._wp)*rn_lambda ! Horizontal scale in meters 351 zn2 = 3.e-3**2 352 zH = 0.5_wp * 5000._wp 353 ! 354 zr_lambda2 = 1._wp / zlambda**2 355 zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 356 ! 357 DO_2D( 1, 1, 1, 1 ) 358 zx = glamt(ji,jj) * 1.e3 359 zy = gphit(ji,jj) * 1.e3 360 ! ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 361 zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal * zy 362 pssh(ji,jj) = 0. 363 DO jl=1,5 364 zdt = pssh(ji,jj) 365 zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH)) ! F'(z) 366 zrho1 = rho0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 367 pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1) ! ssh = Psurf / (Rho*g) 368 END DO 369 END_2D 370 ! 371 END SELECT 372 ! !== add noise ==! 302 373 IF (ln_sshnoise) THEN 303 374 CALL RANDOM_SEED() 304 375 CALL RANDOM_NUMBER(zrandom) 305 376 pssh(:,:) = pssh(:,:) + ( 0.1 * zrandom(:,:) - 0.05 ) 306 END IF 307 CALL lbc_lnk( 'usrdef_istate', pssh, 'T', 1. ) 308 CALL lbc_lnk( 'usrdef_istate', pts , 'T', 1. ) 309 CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) 310 311 END SUBROUTINE usr_def_istate 312 377 ENDIF 378 CALL lbc_lnk( 'usrdef_istate_ssh', pssh, 'T', 1. ) 379 ! 380 END SUBROUTINE usr_def_istate_ssh 381 313 382 !!====================================================================== 314 383 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/CPL_OASIS/EXPREF/namelist_cfg
r14037 r14062 367 367 !----------------------------------------------------------------------- 368 368 ln_dynvor_een = .true. ! energy & enstrophy scheme 369 nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4370 369 / 371 370 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/ISOMIP+/MY_SRC/istate.F90
r14037 r14062 117 117 CALL dta_tsd( nit000, 'ini', ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 118 118 ! 119 ssh(:,:,Kbb) = 0._wp ! set the ocean at rest 120 uu (:,:,:,Kbb) = 0._wp 121 vv (:,:,:,Kbb) = 0._wp 119 uu (:,:,:,Kbb) = 0._wp 120 vv (:,:,:,Kbb) = 0._wp 122 121 ! 123 IF( ll_wd ) THEN124 ssh(:,:,Kbb) = -ssh_ref ! Added in 30 here for bathy that adds 30 as Iterative test CEOD125 !126 ! Apply minimum wetdepth criterion127 !128 DO_2D( 1, 1, 1, 1 )129 IF( ht_0(ji,jj) + ssh(ji,jj,Kbb) < rn_wdmin1 ) THEN130 ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) )131 ENDIF132 END_2D133 ENDIF134 !135 122 ELSE ! user defined initial T and S 136 123 DO jk = 1, jpk 137 124 zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 138 125 END DO 139 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) , ssh(:,:,Kbb))126 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) 140 127 ENDIF 141 128 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 142 ssh (:,:,Kmm) = ssh(:,:,Kbb)143 129 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 144 130 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/ISOMIP/MY_SRC/usrdef_istate.F90
r10074 r14062 9 9 !! History : NEMO ! 2016-11 (S. Flavoni) Original code 10 10 !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case 11 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 11 12 !!---------------------------------------------------------------------- 12 13 … … 24 25 PRIVATE 25 26 26 PUBLIC usr_def_istate ! called by istate.F90 27 PUBLIC usr_def_istate ! called by istate.F90 28 PUBLIC usr_def_istate_ssh ! called by domqco.F90 27 29 28 30 !!---------------------------------------------------------------------- … … 33 35 CONTAINS 34 36 35 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)37 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 36 38 !!---------------------------------------------------------------------- 37 39 !! *** ROUTINE usr_def_istate *** … … 48 50 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 49 51 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 50 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height51 !52 INTEGER :: jk ! dummy loop indices53 52 !!---------------------------------------------------------------------- 54 53 ! … … 58 57 pu (:,:,:) = 0._wp ! ocean at rest 59 58 pv (:,:,:) = 0._wp 60 pssh(:,:) = 0._wp61 !62 59 ! ! T & S profiles 63 60 pts(:,:,:,jp_tem) = - 1.9 * ptmask(:,:,:) ! ISOMIP configuration : start from constant T+S fields … … 66 63 END SUBROUTINE usr_def_istate 67 64 65 66 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 67 !!---------------------------------------------------------------------- 68 !! *** ROUTINE usr_def_istate_ssh *** 69 !! 70 !! ** Purpose : Initialization of ssh 71 !! Here ISOMIP configuration 72 !! 73 !! ** Method : set ssh to 0 74 !!---------------------------------------------------------------------- 75 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 76 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 77 !!---------------------------------------------------------------------- 78 ! 79 IF(lwp) WRITE(numout,*) 80 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : ISOMIP configuration, analytical definition of initial state' 81 ! 82 pssh(:,:) = 0._wp 83 ! 84 END SUBROUTINE usr_def_istate_ssh 85 68 86 !!====================================================================== 69 87 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_ubs_cfg
r14037 r14062 201 201 ln_dynvor_mix = .false. ! mixed scheme 202 202 ln_dynvor_een = .false. ! energy & enstrophy scheme 203 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)204 203 / 205 204 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ens_cfg
r14037 r14062 129 129 ln_dynvor_mix = .false. ! mixed scheme 130 130 ln_dynvor_een = .false. ! energy & enstrophy scheme 131 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)132 131 / 133 132 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/LOCK_EXCHANGE/MY_SRC/usrdef_istate.F90
r12489 r14062 8 8 !!====================================================================== 9 9 !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 23 24 PRIVATE 24 25 25 PUBLIC usr_def_istate ! called by istate.F90 26 PUBLIC usr_def_istate ! called by istate.F90 27 PUBLIC usr_def_istate_ssh ! called by domqco.F90 26 28 27 29 !!---------------------------------------------------------------------- … … 32 34 CONTAINS 33 35 34 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)36 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 35 37 !!---------------------------------------------------------------------- 36 38 !! *** ROUTINE usr_def_istate *** … … 47 49 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 48 50 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 49 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height50 51 ! 51 52 INTEGER :: jk ! dummy loop indices … … 65 66 pu (:,:,:) = 0._wp ! ocean at rest 66 67 pv (:,:,:) = 0._wp 67 pssh(:,:) = 0._wp68 68 ! 69 69 ! ! T & S profiles … … 78 78 END SUBROUTINE usr_def_istate 79 79 80 81 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 82 !!---------------------------------------------------------------------- 83 !! *** ROUTINE usr_def_istate_ssh *** 84 !! 85 !! ** Purpose : Initialization of ssh 86 !! Here LOCK_EXCHANGE configuration 87 !! 88 !! ** Method : set ssh to 0 89 !!---------------------------------------------------------------------- 90 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 91 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 92 !!---------------------------------------------------------------------- 93 ! 94 IF(lwp) WRITE(numout,*) 95 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : LOCK_EXCHANGE configuration, analytical definition of initial state' 96 ! 97 pssh(:,:) = 0._wp 98 ! 99 END SUBROUTINE usr_def_istate_ssh 100 80 101 !!====================================================================== 81 102 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg
r14037 r14062 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg
r14037 r14062 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg
r14037 r14062 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg
r14037 r14062 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_zps_FCT2_flux_ubs_cfg
r14037 r14062 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg
r14037 r14062 201 201 ln_dynvor_mix = .false. ! mixed scheme 202 202 ln_dynvor_een = .false. ! energy & enstrophy scheme 203 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)204 203 / 205 204 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_vect_een_cfg
r14037 r14062 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .true. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/MY_SRC/usrdef_istate.F90
r12489 r14062 8 8 !!============================================================================== 9 9 !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 23 24 PRIVATE 24 25 25 PUBLIC usr_def_istate ! called by istate.F90 26 26 PUBLIC usr_def_istate ! called by istate.F90 27 PUBLIC usr_def_istate_ssh ! called by domqco.F90 28 27 29 !!---------------------------------------------------------------------- 28 30 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 32 34 CONTAINS 33 35 34 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)36 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 35 37 !!---------------------------------------------------------------------- 36 38 !! *** ROUTINE usr_def_istate *** … … 47 49 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 48 50 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 49 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height50 51 ! 51 52 INTEGER :: jk ! dummy loop indices … … 65 66 pu (:,:,:) = 0._wp ! ocean at rest 66 67 pv (:,:,:) = 0._wp 67 pssh(:,:) = 0._wp68 68 ! 69 69 ! ! T & S profiles … … 78 78 END SUBROUTINE usr_def_istate 79 79 80 81 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 82 !!---------------------------------------------------------------------- 83 !! *** ROUTINE usr_def_istate_ssh *** 84 !! 85 !! ** Purpose : Initialization of the ssh 86 !! Here OVERFLOW configuration 87 !! 88 !! ** Method : set ssh to 0 89 !!---------------------------------------------------------------------- 90 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 91 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 92 !!---------------------------------------------------------------------- 93 ! 94 IF(lwp) WRITE(numout,*) 95 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : OVERFLOW configuration, analytical definition of initial state' 96 ! 97 pssh(:,:) = 0._wp 98 ! 99 END SUBROUTINE usr_def_istate_ssh 100 80 101 !!====================================================================== 81 102 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90
r13295 r14062 193 193 pdept(ji,jj,ik+1) = pdepw(ji,jj,ik+1) + pe3t (ji,jj,ik+1) * 0.5_wp 194 194 pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik) ! = pe3t (ji,jj,ik ) 195 pe3w (ji,jj,ik ) = pdept(ji,jj,ik ) - pdept(ji,jj,ik-1) ! st caution ik > 1 195 196 END_2D 196 197 ! ! bottom scale factors and depth at U-, V-, UW and VW-points -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/VORTEX/EXPREF/1_namelist_cfg
r14037 r14062 195 195 ln_dynvor_mix = .false. ! mixed scheme 196 196 ln_dynvor_een = .true. ! energy & enstrophy scheme 197 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)198 197 / 199 198 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/VORTEX/EXPREF/namelist_cfg
r14037 r14062 188 188 ln_dynvor_mix = .false. ! mixed scheme 189 189 ln_dynvor_een = .true. ! energy & enstrophy scheme 190 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)191 190 / 192 191 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/VORTEX/MY_SRC/usrdef_istate.F90
r13295 r14062 8 8 !!====================================================================== 9 9 !! History : NEMO ! 2017-11 (J. Chanut) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 26 27 PRIVATE 27 28 28 PUBLIC usr_def_istate ! called by istate.F90 29 PUBLIC usr_def_istate ! called by istate.F90 30 PUBLIC usr_def_istate_ssh ! called by domqco.F90 29 31 30 32 !! * Substitutions … … 37 39 CONTAINS 38 40 39 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)41 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 40 42 !!---------------------------------------------------------------------- 41 43 !! *** ROUTINE usr_def_istate *** … … 52 54 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 53 55 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 54 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height55 56 ! 56 57 INTEGER :: ji, jj, jk ! dummy loop indices … … 67 68 zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 68 69 zumax = 1._wp * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 69 zlambda = SQRT(2._wp)*60.e3 ! Horizontal scale in meters 70 zlambda = SQRT(2._wp)*60.e3 ! Horizontal scale in meters 70 71 zn2 = 3.e-3**2 71 72 zH = 0.5_wp * 5000._wp 72 73 ! 73 74 zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 74 !75 ! Sea level:76 za = -zP0 * (1._wp-EXP(-zH)) / (grav*(zH-1._wp + EXP(-zH)))77 DO_2D( 1, 1, 1, 1 )78 zx = glamt(ji,jj) * 1.e379 zy = gphit(ji,jj) * 1.e380 zrho1 = rho0 + za * EXP(-(zx**2+zy**2)/zlambda**2)81 pssh(ji,jj) = zP0 * EXP(-(zx**2+zy**2)/zlambda**2)/(zrho1*grav) * ptmask(ji,jj,1)82 END_2D83 75 ! 84 76 ! temperature: … … 134 126 END SUBROUTINE usr_def_istate 135 127 128 129 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 130 !!---------------------------------------------------------------------- 131 !! *** ROUTINE usr_def_istate *** 132 !! 133 !! ** Purpose : Initialization of ssh 134 !! Here VORTEX configuration 135 !! 136 !! ** Method : Set ssh according to a gaussian anomaly of pressure and associated 137 !! geostrophic velocities 138 !!---------------------------------------------------------------------- 139 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 140 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 141 ! 142 INTEGER :: ji, jj ! dummy loop indices 143 REAL(wp) :: zx, zy, zP0, zumax, zlambda, zf0, zH, zrho1, za 144 !!---------------------------------------------------------------------- 145 ! 146 IF(lwp) WRITE(numout,*) 147 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : VORTEX configuration, analytical definition of initial state' 148 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ ' 149 ! 150 ! 151 ! 152 zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 153 zumax = 1._wp * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 154 zlambda = SQRT(2._wp)*60.e3 ! Horizontal scale in meters 155 zH = 0.5_wp * 5000._wp 156 ! 157 zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 158 ! 159 ! Sea level: 160 za = -zP0 * (1._wp-EXP(-zH)) / (grav*(zH-1._wp + EXP(-zH))) 161 DO_2D( 1, 1, 1, 1 ) 162 zx = glamt(ji,jj) * 1.e3 163 zy = gphit(ji,jj) * 1.e3 164 zrho1 = rho0 + za * EXP(-(zx**2+zy**2)/zlambda**2) 165 pssh(ji,jj) = zP0 * EXP(-(zx**2+zy**2)/zlambda**2)/(zrho1*grav) * ptmask(ji,jj,1) 166 END_2D 167 168 END SUBROUTINE usr_def_istate_ssh 169 136 170 !!====================================================================== 137 171 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/VORTEX/cpp_VORTEX.fcm
r12208 r14062 1 bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif 1 bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/WAD/EXPREF/namelist_cfg
r14037 r14062 330 330 ln_dynvor_mix = .false. ! mixed scheme 331 331 ln_dynvor_een = .true. ! energy & enstrophy scheme 332 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)333 332 / 334 333 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/WAD/MY_SRC/usrdef_istate.F90
r13295 r14062 7 7 !! User defined : set the initial state of a user configuration 8 8 !!====================================================================== 9 !! History : 4.0 ! 2016-03 (S. Flavoni) Original code 9 !! History : 4.0 ! 2016-03 (S. Flavoni) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 24 25 PRIVATE 25 26 26 PUBLIC usr_def_istate ! called in istate.F90 27 PUBLIC usr_def_istate ! called in istate.F90 28 PUBLIC usr_def_istate_ssh ! called in sshwzv.F90 27 29 28 30 !! * Substitutions … … 34 36 !!---------------------------------------------------------------------- 35 37 CONTAINS 36 37 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 38 39 40 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 38 41 !!---------------------------------------------------------------------- 39 42 !! *** ROUTINE usr_def_istate *** … … 42 45 !! Here WAD_TEST_CASES configuration 43 46 !! 44 !! ** Method : - set temprature field47 q !! ** Method : - set temprature field 45 48 !! - set salinity field 46 49 !!---------------------------------------------------------------------- … … 50 53 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 51 54 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 52 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height53 55 INTEGER :: ji, jj ! dummy loop indices 54 56 REAL(wp) :: zi, zj … … 66 68 pu (:,:,:) = 0._wp ! ocean at rest 67 69 pv (:,:,:) = 0._wp 68 pssh(:,:) = 0._wp69 !70 70 ! ! T & S profiles 71 71 pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:) … … 83 83 CASE ( 1 ) ! WAD 1 configuration 84 84 ! ! ==================== 85 !86 85 IF(lwp) WRITE(numout,*) 87 86 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Closed box with EW linear bottom slope' 88 87 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 89 !90 do ji = 1,jpi91 pssh(ji,:) = ( -5.5_wp + 7.4_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1)92 end do93 88 ! ! ==================== 94 89 CASE ( 2, 8 ) ! WAD 2 configuration 95 90 ! ! ==================== 96 !97 91 IF(lwp) WRITE(numout,*) 98 92 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, mid-range initial ssh slope' 99 93 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 100 !101 do ji = 1,jpi102 pssh(ji,:) = ( -1.5_wp + 5.0_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1)103 end do104 94 ! ! ==================== 105 95 CASE ( 3 ) ! WAD 3 configuration 106 96 ! ! ==================== 107 !108 97 IF(lwp) WRITE(numout,*) 109 98 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, extreme initial ssh slope' 110 99 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 111 ! 112 do ji = 1,jpi 113 pssh(ji,:) = ( -4.5_wp + 6.8_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 114 end do 100 ! ! ==================== 101 CASE ( 4 ) ! WAD 4 configuration 102 ! ! ==================== 103 IF(lwp) WRITE(numout,*) 104 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic bowl, mid-range initial ssh slope' 105 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 106 ! ! =========================== 107 CASE ( 5, 7 ) ! WAD 5 and 7 configurations 108 ! ! =========================== 109 IF(lwp) WRITE(numout,*) 110 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Double slope with shelf' 111 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 112 ! ! ==================== 113 CASE ( 6 ) ! WAD 6 configuration 114 ! ! ==================== 115 IF(lwp) WRITE(numout,*) 116 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel with gaussian ridge' 117 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 118 ! 119 DO ji = mi0(jpiglo/2), mi0(jpiglo) 120 pts(ji,:,:,jp_sal) = 30._wp 121 END DO 122 ! 123 ! 124 ! ! =========================== 125 CASE DEFAULT ! NONE existing configuration 126 ! ! =========================== 127 WRITE(ctmp1,*) 'WAD test with a ', nn_cfg,' option is not coded' 128 ! 129 CALL ctl_stop( ctmp1 ) 130 ! 131 END SELECT 132 ! 133 END SUBROUTINE usr_def_istate 134 135 136 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 137 !!---------------------------------------------------------------------- 138 !! *** ROUTINE usr_def_istate_ssh *** 139 !! 140 !! ** Purpose : Initialization of the dynamics and tracers 141 !! Here WAD_TEST_CASES configuration 142 !! 143 !! ** Method : - set ssh 144 !!---------------------------------------------------------------------- 145 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 146 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height 147 INTEGER :: ji, jj ! dummy loop indices 148 REAL(wp) :: zi, zj 149 ! 150 INTEGER :: jk ! dummy loop indices 151 REAL(wp) :: zdam ! location of dam [Km] 152 !!---------------------------------------------------------------------- 153 ! 154 ! 155 SELECT CASE ( nn_cfg ) 156 ! ! ==================== 157 CASE ( 1 ) ! WAD 1 configuration 158 ! ! ==================== 159 ! 160 IF(lwp) WRITE(numout,*) 161 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Closed box with EW linear bottom slope' 162 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 163 ! 164 DO ji = 1,jpi 165 pssh(ji,:) = ( -5.5_wp + 7.4_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 166 END DO 167 ! ! ==================== 168 CASE ( 2, 8 ) ! WAD 2 configuration 169 ! ! ==================== 170 ! 171 IF(lwp) WRITE(numout,*) 172 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, mid-range initial ssh slope' 173 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 174 ! 175 DO ji = 1,jpi 176 pssh(ji,:) = ( -1.5_wp + 5.0_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 177 END DO 178 ! ! ==================== 179 CASE ( 3 ) ! WAD 3 configuration 180 ! ! ==================== 181 ! 182 IF(lwp) WRITE(numout,*) 183 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, extreme initial ssh slope' 184 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 185 ! 186 DO ji = 1,jpi 187 pssh(ji,:) = ( -4.5_wp + 6.8_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 188 END DO 115 189 116 190 ! … … 140 214 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 141 215 ! 142 doji = 1,jpi143 pssh(ji,:) = ( -2.5_wp + 5.5_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1)144 end do216 DO ji = 1,jpi 217 pssh(ji,:) = ( -2.5_wp + 5.5_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 218 END DO 145 219 146 220 ! … … 153 227 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 154 228 ! 155 do ji = 1,jpi 156 pssh(ji,:) = ( -2.5_wp + 5.5_wp*(50._wp-glamt(ji,1))/50._wp)*ptmask(ji,:,1) 157 end do 158 ! 159 do ji = mi0(jpiglo/2), mi0(jpiglo) 160 pts(ji,:,:,jp_sal) = 30._wp 161 pssh(ji,:) = -0.1*ptmask(ji,:,1) 162 end do 229 DO ji = 1,jpi 230 pssh(ji,:) = ( -2.5_wp + 5.5_wp*(50._wp-glamt(ji,1))/50._wp)*ptmask(ji,:,1) 231 END DO 232 ! 233 DO ji = mi0(jpiglo/2), mi0(jpiglo) 234 pssh(ji,:) = -0.1*ptmask(ji,:,1) 235 END DO 163 236 ! 164 237 ! … … 182 255 END_2D 183 256 ! 184 END SUBROUTINE usr_def_istate 257 END SUBROUTINE usr_def_istate_ssh 185 258 186 259 !!====================================================================== -
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/tests/demo_cfgs.txt
r14037 r14062 12 12 STATION_ASF OCE 13 13 CPL_OASIS OCE TOP ICE NST 14 SWG OCE SWE 14 15 C1D_ASICS OCE 15 16 ICE_RHEO OCE SAS ICE
Note: See TracChangeset
for help on using the changeset viewer.