diff --git a/cfgs/SHARED/field_def_nemo-ice.xml b/cfgs/SHARED/field_def_nemo-ice.xml index 6f444b4563f398c3b44021512551548252a10bf7..b04c13e1f704d0606406d8dd243cd73b986a8257 100644 --- a/cfgs/SHARED/field_def_nemo-ice.xml +++ b/cfgs/SHARED/field_def_nemo-ice.xml @@ -18,7 +18,7 @@ <field_group id="SBC" > <!-- time step automaticaly defined based on nn_fsbc --> <!-- 2D variables --> - <field_group id="SBC_2D" grid_ref="grid_T_2D" > + <field_group id="SBC_2D" grid_ref="grid_T_2D_inner" > <!-- =================== --> <!-- standard ice fields --> @@ -311,7 +311,7 @@ </field_group> <!-- SBC_2D --> <!-- categories --> - <field_group id="SBC_3D" grid_ref="grid_T_ncatice" > + <field_group id="SBC_3D" grid_ref="grid_T_ncatice_inner" > <!-- standard ice fields --> <field id="iceconc_cat" long_name="Sea-ice concentration per category" unit="" /> @@ -386,7 +386,7 @@ --> <!-- output variables for my configuration (example) --> - <field_group id="myvarICE" grid_ref="grid_T_2D" > + <field_group id="myvarICE" > <!-- ice mask --> <field field_ref="icemask" name="simsk" /> <field field_ref="icemask05" name="simsk05" /> @@ -495,7 +495,7 @@ </field_group> - <field_group id="myvarICE_cat" grid_ref="grid_T_ncatice" > + <field_group id="myvarICE_cat" > <!-- categories --> <field field_ref="icemask_cat" name="simskcat"/> @@ -524,7 +524,7 @@ <field field_ref="ilbgvol_tot" name="ilbgvol_tot" /> </field_group> - <field_group id="ICE_budget" grid_ref="grid_T_2D" > + <field_group id="ICE_budget" > <!-- general --> <field field_ref="icemask" name="simsk" /> <field field_ref="iceconc" name="siconc" /> @@ -579,7 +579,7 @@ </field_group> <!-- SIMIP daily fields --> - <field_group id="SIday_fields" grid_ref="grid_T_2D" > + <field_group id="SIday_fields" > <field field_ref="icepres" name="sitimefrac" /> <field field_ref="iceconc_pct" name="siconc" /> <field field_ref="icethic_cmip" name="sithick" /> @@ -591,7 +591,7 @@ </field_group> <!-- SIMIP monthly fields --> - <field_group id="SImon_fields" grid_ref="grid_T_2D" > + <field_group id="SImon_fields" > <!-- Sea-ice state variables --> <field field_ref="icepres" name="sitimefrac" /> <field field_ref="iceconc_pct" name="siconc" /> diff --git a/cfgs/SHARED/field_def_nemo-oce.xml b/cfgs/SHARED/field_def_nemo-oce.xml index 838cd2834cb3d8daad80c923b1f658e41fcd36e1..f1c958b874938403bb1b8a0b8da10f8c4978baa2 100644 --- a/cfgs/SHARED/field_def_nemo-oce.xml +++ b/cfgs/SHARED/field_def_nemo-oce.xml @@ -172,10 +172,10 @@ that are available in the tidal-forcing implementation (see <field id="wetdep" long_name="wet depth" standard_name="wet_depth" unit="m" /> <field id="sshmax" long_name="max of sea surface height" field_ref="ssh" operation="maximum" /> - <field id="mldkz5" long_name="Turbocline depth (Kz = 5e-4)" standard_name="ocean_mixed_layer_thickness_defined_by_vertical_tracer_diffusivity" unit="m" /> - <field id="mldr10_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" /> - <field id="mldr10_1max" long_name="Max of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="maximum" /> - <field id="mldr10_1min" long_name="Min of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="minimum" /> + <field id="mldkz5" long_name="Turbocline depth (Kz = 5e-4)" standard_name="ocean_mixed_layer_thickness_defined_by_vertical_tracer_diffusivity" unit="m" grid_ref="grid_T_2D_inner" /> + <field id="mldr10_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" grid_ref="grid_T_2D_inner" /> + <field id="mldr10_1max" long_name="Max of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="maximum" grid_ref="grid_T_2D_inner" /> + <field id="mldr10_1min" long_name="Min of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="minimum" grid_ref="grid_T_2D_inner" /> <field id="heatc" long_name="Heat content vertically integrated" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" grid_ref="grid_T_2D_inner" /> <field id="saltc" long_name="Salt content vertically integrated" unit="PSU*kg/m2" grid_ref="grid_T_2D_inner" /> <field id="salt2c" long_name="square of Salt content vertically integrated" unit="PSU2*kg/m2" grid_ref="grid_T_2D_inner" /> @@ -410,7 +410,7 @@ that are available in the tidal-forcing implementation (see <!-- SBC --> <field_group id="SBC" > <!-- time step automaticaly defined based on nn_fsbc --> - <field_group id="SBC_2D" grid_ref="grid_T_2D" > + <field_group id="SBC_2D" grid_ref="grid_T_2D_inner" > <field id="empmr" long_name="Net Upward Water Flux" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" /> <field id="empbmr" long_name="Net Upward Water Flux at pre. tstep" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" /> @@ -423,20 +423,20 @@ that are available in the tidal-forcing implementation (see <field id="precip" long_name="Total precipitation" standard_name="precipitation_flux" unit="kg/m2/s" /> <field id="wclosea" long_name="closed sea empmr correction" standard_name="closea_empmr" unit="kg/m2/s" /> - <field id="qt" long_name="Net Downward Heat Flux" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" /> - <field id="qns" long_name="non solar Downward Heat Flux" unit="W/m2" /> - <field id="qsr" long_name="Shortwave Radiation" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" /> - <field id="qsr3d" long_name="Shortwave Radiation 3D distribution" standard_name="downwelling_shortwave_flux_in_sea_water" unit="W/m2" grid_ref="grid_T_3D" /> - <field id="qrp" long_name="Surface Heat Flux: Damping" standard_name="heat_flux_into_sea_water_due_to_newtonian_relaxation" unit="W/m2" /> + <field id="qt" long_name="Net Downward Heat Flux" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" /> + <field id="qns" long_name="non solar Downward Heat Flux" unit="W/m2" /> + <field id="qsr" long_name="Shortwave Radiation" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" /> + <field id="qsr3d" long_name="Shortwave Radiation 3D distribution" standard_name="downwelling_shortwave_flux_in_sea_water" unit="W/m2" grid_ref="grid_T_3D" /> + <field id="qrp" long_name="Surface Heat Flux: Damping" standard_name="heat_flux_into_sea_water_due_to_newtonian_relaxation" unit="W/m2" /> <field id="qclosea" long_name="closed sea heat content flux" standard_name="closea_heat_content_downward_flux" unit="W/m2" /> - <field id="erp" long_name="Surface Water Flux: Damping" standard_name="water_flux_out_of_sea_water_due_to_newtonian_relaxation" unit="kg/m2/s" /> - <field id="taum" long_name="wind stress module" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" /> - <field id="wspd" long_name="wind speed module" standard_name="wind_speed" unit="m/s" /> - <field id="utau" long_name="Wind Stress along i-axis" standard_name="surface_downward_x_stress" unit="N/m2" /> - <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" /> + <field id="erp" long_name="Surface Water Flux: Damping" standard_name="water_flux_out_of_sea_water_due_to_newtonian_relaxation" unit="kg/m2/s" /> + <field id="taum" long_name="wind stress module" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" /> + <field id="wspd" long_name="wind speed module" standard_name="wind_speed" unit="m/s" /> + <field id="utau" long_name="Wind Stress along i-axis" standard_name="surface_downward_x_stress" unit="N/m2" /> + <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" /> <!-- * variable relative to atmospheric pressure forcing : available with ln_apr_dyn --> - <field id="ssh_ib" long_name="Inverse barometer sea surface height" standard_name="sea_surface_height_correction_due_to_air_pressure_at_low_frequency" unit="m" /> + <field id="ssh_ib" long_name="Inverse barometer sea surface height" standard_name="sea_surface_height_correction_due_to_air_pressure_at_low_frequency" unit="m" grid_ref="grid_T_2D" /> <!-- *_oce variables available with ln_blk_clio or ln_blk_core --> <field id="rho_air" long_name="Air density at 10m above sea surface" standard_name="rho_air_10m" unit="kg/m3" /> @@ -473,9 +473,9 @@ that are available in the tidal-forcing implementation (see <field id="snow_ai_cea" long_name="Snow over sea-ice (cell average)" standard_name="snowfall_flux" unit="kg/m2/s" /> <field id="subl_ai_cea" long_name="Sublimation over sea-ice (cell average)" standard_name="surface_snow_and_ice_sublimation_flux" unit="kg/m2/s" /> <field id="icealb_cea" long_name="Ice albedo (cell average)" standard_name="sea_ice_albedo" unit="1" /> - <field id="calving_cea" long_name="Calving" standard_name="water_flux_into_sea_water_from_icebergs" unit="kg/m2/s" /> - <field id="iceberg_cea" long_name="Iceberg" standard_name="water_flux_into_sea_water_from_icebergs" unit="kg/m2/s" /> - <field id="iceshelf_cea" long_name="Iceshelf" standard_name="water_flux_into_sea_water_from_iceshelf" unit="kg/m2/s" /> + <field id="calving_cea" long_name="Calving" standard_name="water_flux_into_sea_water_from_icebergs" unit="kg/m2/s" grid_ref="grid_T_2D" /> + <field id="iceberg_cea" long_name="Iceberg" standard_name="water_flux_into_sea_water_from_icebergs" unit="kg/m2/s" grid_ref="grid_T_2D" /> + <field id="iceshelf_cea" long_name="Iceshelf" standard_name="water_flux_into_sea_water_from_iceshelf" unit="kg/m2/s" grid_ref="grid_T_2D" /> <!-- available if key_oasis3 + conservative method --> @@ -512,7 +512,7 @@ that are available in the tidal-forcing implementation (see <field id="vflx_fwb_cea" long_name="volume flux due to fwb" standard_name="volume_flux_due_to_fwb" unit="kg/m2/s" /> <!-- ice field (nn_ice=1) --> - <field id="ice_cover" long_name="Ice fraction" standard_name="sea_ice_area_fraction" unit="1" /> + <field id="ice_cover" long_name="Ice fraction" standard_name="sea_ice_area_fraction" unit="1" grid_ref="grid_T_2D" /> <!-- dilution --> <field id="emp_x_sst" long_name="Concentration/Dilution term on SST" unit="kg*degC/m2/s" /> @@ -521,13 +521,13 @@ that are available in the tidal-forcing implementation (see <field id="rnf_x_sss" long_name="Runoff term on SSS" unit="kg*1e-3/m2/s" /> <!-- sbcssm variables --> - <field id="sst_m" unit="degC" /> - <field id="sss_m" unit="psu" /> - <field id="ssu_m" unit="m/s" /> - <field id="ssv_m" unit="m/s" /> - <field id="ssh_m" unit="m" /> - <field id="e3t_m" unit="m" /> - <field id="frq_m" unit="-" /> + <field id="sst_m" unit="degC" grid_ref="grid_T_2D" /> + <field id="sss_m" unit="psu" grid_ref="grid_T_2D" /> + <field id="ssu_m" unit="m/s" grid_ref="grid_T_2D" /> + <field id="ssv_m" unit="m/s" grid_ref="grid_T_2D" /> + <field id="ssh_m" unit="m" grid_ref="grid_T_2D" /> + <field id="e3t_m" unit="m" grid_ref="grid_T_2D" /> + <field id="frq_m" unit="-" grid_ref="grid_T_2D" /> </field_group> @@ -718,16 +718,16 @@ that are available in the tidal-forcing implementation (see <field id="weiv_heattr3d" long_name="ocean bolus heat transport" standard_name="ocean_heat_z_transport_due_to_bolus_advection" unit="W" /> <field id="weiv_salttr3d" long_name="ocean bolus salt transport" standard_name="ocean_salt_z_transport_due_to_bolus_advection" unit="kg" /> - <field id="avt" long_name="vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> + <field id="avt" long_name="vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" /> <field id="avt_e3w" long_name="vertical heat diffusivity * e3w" unit="m3/s" > avt * e3w </field> - <field id="logavt" long_name="logarithm of vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> + <field id="logavt" long_name="logarithm of vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" /> <field id="avm" long_name="vertical eddy viscosity" standard_name="ocean_vertical_momentum_diffusivity" unit="m2/s" /> <field id="avm_e3w" long_name="vertical eddy viscosity * e3w" unit="m3/s" > avm * e3w </field> <!-- avs: /= avt with ln_zdfddm=T --> - <field id="avs" long_name="salt vertical eddy diffusivity" standard_name="ocean_vertical_salt_diffusivity" unit="m2/s" /> + <field id="avs" long_name="salt vertical eddy diffusivity" standard_name="ocean_vertical_salt_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" /> <field id="avs_e3w" long_name="vertical salt diffusivity * e3w" unit="m3/s" > avs * e3w </field> - <field id="logavs" long_name="logarithm of salt vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> + <field id="logavs" long_name="logarithm of salt vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" /> <!-- avt_evd and avm_evd: available with ln_zdfevd --> <field id="avt_evd" long_name="convective enhancement of vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_convection" unit="m2/s" /> @@ -740,11 +740,11 @@ that are available in the tidal-forcing implementation (see <!-- avt_tide: available with ln_zdfiwm=T --> - <field id="av_ratio" long_name="S over T diffusivity ratio" standard_name="salinity_over_temperature_diffusivity_ratio" unit="1" /> - <field id="av_wave" long_name="internal wave-induced vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_internal_waves" unit="m2/s" /> - <field id="bflx_iwm" long_name="internal wave-induced buoyancy flux" standard_name="buoyancy_flux_due_to_internal_waves" unit="W/kg" /> - <field id="pcmap_iwm" long_name="power consumed by wave-driven mixing" standard_name="vertically_integrated_power_consumption_by_wave_driven_mixing" unit="W/m2" grid_ref="grid_W_2D" /> - <field id="emix_iwm" long_name="power density available for mixing" standard_name="power_available_for_mixing_from_breaking_internal_waves" unit="W/kg" /> + <field id="av_ratio" long_name="S over T diffusivity ratio" standard_name="salinity_over_temperature_diffusivity_ratio" unit="1" grid_ref="grid_W_3D_inner" /> + <field id="av_wave" long_name="internal wave-induced vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_internal_waves" unit="m2/s" grid_ref="grid_W_3D_inner" /> + <field id="bflx_iwm" long_name="internal wave-induced buoyancy flux" standard_name="buoyancy_flux_due_to_internal_waves" unit="W/kg" grid_ref="grid_W_3D_inner" /> + <field id="pcmap_iwm" long_name="power consumed by wave-driven mixing" standard_name="vertically_integrated_power_consumption_by_wave_driven_mixing" unit="W/m2" grid_ref="grid_W_2D_inner" /> + <field id="emix_iwm" long_name="power density available for mixing" standard_name="power_available_for_mixing_from_breaking_internal_waves" unit="W/kg" grid_ref="grid_W_3D_inner" /> <!-- variables available with WAVE (ln_wave=T) --> <field id="wstokes" long_name="Stokes Drift vertical velocity" standard_name="upward_StokesDrift_velocity" unit="m/s" /> @@ -757,11 +757,11 @@ that are available in the tidal-forcing implementation (see <field id="bn2" long_name="squared Brunt-Vaisala frequency" unit="s-2" /> <!-- dissipation diagnostics (note: ediss_k is only available with tke scheme) --> - <field id="avt_k" long_name="vertical eddy diffusivity from closure schemes" standard_name="ocean_vertical_eddy_diffusivity" unit="m2/s" /> <field id="avm_k" long_name="vertical eddy viscosity from closure schemes" standard_name="ocean_vertical_eddy_viscosity" unit="m2/s" /> - <field id="ediss_k" long_name="Kolmogorov energy dissipation (tke scheme)" standard_name="Kolmogorov_energy_dissipation" unit="W/kg" /> - <field id="eshear_k" long_name="energy source from vertical shear" standard_name="energy_source_from_shear" unit="W/kg" /> - <field id="estrat_k" long_name="energy sink from stratification" standard_name="energy_sink_from_stratification" unit="W/kg" /> + <field id="avt_k" long_name="vertical eddy diffusivity from closure schemes" standard_name="ocean_vertical_eddy_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" /> + <field id="ediss_k" long_name="Kolmogorov energy dissipation (tke scheme)" standard_name="Kolmogorov_energy_dissipation" unit="W/kg" grid_ref="grid_W_3D_inner" /> + <field id="eshear_k" long_name="energy source from vertical shear" standard_name="energy_source_from_shear" unit="W/kg" grid_ref="grid_W_3D_inner" /> + <field id="estrat_k" long_name="energy sink from stratification" standard_name="energy_sink_from_stratification" unit="W/kg" grid_ref="grid_W_3D_inner" /> </field_group> diff --git a/cfgs/SHARED/namelist_ref b/cfgs/SHARED/namelist_ref index dc77ca9a56b679a9a8b7c1dd80edbac11191ea24..f146b16f520b78980d840f0ff104ac0b37d56a4a 100644 --- a/cfgs/SHARED/namelist_ref +++ b/cfgs/SHARED/namelist_ref @@ -883,6 +883,9 @@ ! ! ! S-EOS coefficients (ln_seos=T): ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + ! ! dT = T-rn_T0 ; dS = S-rn_S0 + rn_T0 = 10. ! reference temperature + rn_S0 = 35. ! reference salinity rn_a0 = 1.6550e-1 ! thermal expension coefficient rn_b0 = 7.6554e-1 ! saline expension coefficient rn_lambda1 = 5.9520e-2 ! cabbeling coeff in T^2 (=0 for linear eos) diff --git a/src/ABL/sbcabl.F90 b/src/ABL/sbcabl.F90 index c2c1d13c12941ac034f32e782f553b30bba719c2..cd771f978c5dc566915c866f214bbda24edda2d4 100644 --- a/src/ABL/sbcabl.F90 +++ b/src/ABL/sbcabl.F90 @@ -44,6 +44,8 @@ MODULE sbcabl PUBLIC sbc_abl_init ! routine called in sbcmod module PUBLIC sbc_abl ! routine called in sbcmod module + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OPA 3.7 , NEMO-consortium (2014) !! $Id: sbcabl.F90 6416 2016-04-01 12:22:17Z clem $ @@ -340,7 +342,7 @@ CONTAINS CALL blk_oce_1( kt, u_abl(:,:,2,nt_n ), v_abl(:,:,2,nt_n ), & ! <<= in & tq_abl(:,:,2,nt_n,jp_ta), tq_abl(:,:,2,nt_n,jp_qa), & ! <<= in - & sf(jp_slp )%fnow(:,:,1) , sst_m, ssu_m, ssv_m , & ! <<= in + & sf(jp_slp )%fnow(:,:,1) , sst_m(A2D(0)), ssu_m(A2D(0)), ssv_m(A2D(0)), & ! <<= in & sf(jp_uoatm)%fnow(:,:,1), sf(jp_voatm)%fnow(:,:,1), & ! <<= in & sf(jp_qsr )%fnow(:,:,1) , sf(jp_qlw )%fnow(:,:,1) , & ! <<= in & tsk_m, zssq, zcd_du, zsen, zlat, zevp ) ! =>> out @@ -348,7 +350,7 @@ CONTAINS #if defined key_si3 CALL blk_ice_1( u_abl(:,:,2,nt_n ), v_abl(:,:,2,nt_n ), & ! <<= in & tq_abl(:,:,2,nt_n,jp_ta), tq_abl(:,:,2,nt_n,jp_qa), & ! <<= in - & sf(jp_slp)%fnow(:,:,1) , u_ice, v_ice, tm_su , & ! <<= in + & sf(jp_slp)%fnow(:,:,1) , u_ice(A2D(0)), v_ice(A2D(0)), tm_su , & ! <<= in & pseni=zseni, pevpi=zevpi, pssqi=zssqi, pcd_dui=zcd_dui ) ! <<= out #endif diff --git a/src/ICE/ice.F90 b/src/ICE/ice.F90 index 67bce2c4ae0e5ab22daceb6760abbceef7a2ef66..889e726d79dfcd8760d35dd56ca303cce4c1bd01 100644 --- a/src/ICE/ice.F90 +++ b/src/ICE/ice.F90 @@ -451,6 +451,8 @@ MODULE ice REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_bot !: Bottom conduction flux (W/m2) REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_top !: Surface conduction flux (W/m2) ! + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/ICE 4.0 , NEMO Consortium (2018) !! $Id: ice.F90 15388 2021-10-17 11:33:47Z clem $ @@ -464,71 +466,103 @@ CONTAINS !!----------------------------------------------------------------- INTEGER :: ice_alloc ! - INTEGER :: ierr(16), ii + INTEGER :: ierr(21), ii !!----------------------------------------------------------------- ierr(:) = 0 + ii = 0 + ! ----------------- ! + ! == FULL ARRAYS == ! + ! ----------------- ! + + ! * Ice global state variables + ii = ii + 1 + ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) , STAT=ierr(ii) ) - ii = 1 - ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , ht_i_new (jpi,jpj) , fraz_frac (jpi,jpj) , & - & strength (jpi,jpj) , stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) , & - & delta_i (jpi,jpj) , divu_i (jpi,jpj) , shear_i (jpi,jpj) , & - & aniso_11 (jpi,jpj) , aniso_12 (jpi,jpj) , rdg_conv (jpi,jpj) , STAT=ierr(ii) ) + ii = ii + 1 + ALLOCATE( h_i (jpi,jpj,jpl) , a_i (jpi,jpj,jpl) , v_i (jpi,jpj,jpl) , & + & v_s (jpi,jpj,jpl) , h_s (jpi,jpj,jpl) , & + & s_i (jpi,jpj,jpl) , sv_i(jpi,jpj,jpl) , o_i (jpi,jpj,jpl) , oa_i (jpi,jpj,jpl) , & + & a_ip (jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl), & + & v_il (jpi,jpj,jpl) , h_il(jpi,jpj,jpl) , & + & t_su (jpi,jpj,jpl) , t_s (jpi,jpj,nlay_s,jpl) , t_i(jpi,jpj,nlay_i,jpl) , sz_i(jpi,jpj,nlay_i,jpl) , & + & ato_i(jpi,jpj) , STAT = ierr(ii) ) ii = ii + 1 - ALLOCATE( t_bo (jpi,jpj) , wfx_snw_sni(jpi,jpj) , & - & wfx_snw (jpi,jpj) , wfx_snw_dyn(jpi,jpj) , wfx_snw_sum(jpi,jpj) , wfx_snw_sub(jpi,jpj) , & - & wfx_ice (jpi,jpj) , wfx_sub (jpi,jpj) , wfx_ice_sub(jpi,jpj) , wfx_lam (jpi,jpj) , & - & wfx_pnd (jpi,jpj) , & - & wfx_bog (jpi,jpj) , wfx_dyn (jpi,jpj) , wfx_bom(jpi,jpj) , wfx_sum(jpi,jpj) , & - & wfx_res (jpi,jpj) , wfx_sni (jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) , & - & rn_amax_2d (jpi,jpj) , & - & qsb_ice_bot(jpi,jpj) , qlead (jpi,jpj) , & - & sfx_res (jpi,jpj) , sfx_bri (jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj) , sfx_lam(jpi,jpj) , & - & sfx_bog (jpi,jpj) , sfx_bom (jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) , & - & hfx_res (jpi,jpj) , hfx_snw (jpi,jpj) , hfx_sub(jpi,jpj) , & - & qt_atm_oi (jpi,jpj) , qt_oce_ai (jpi,jpj) , fhld (jpi,jpj) , & - & hfx_sum (jpi,jpj) , hfx_bom (jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , & - & hfx_opw (jpi,jpj) , hfx_thd (jpi,jpj) , hfx_dyn(jpi,jpj) , hfx_spr(jpi,jpj) , & - & hfx_err_dif(jpi,jpj) , wfx_err_sub(jpi,jpj) , STAT=ierr(ii) ) + ALLOCATE( e_s(jpi,jpj,nlay_s,jpl) , e_i(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) ) - ! * Ice global state variables + ! * Before values of global variables ii = ii + 1 - ALLOCATE( qtr_ice_bot(jpi,jpj,jpl) , cnd_ice(jpi,jpj,jpl) , t1_ice(jpi,jpj,jpl) , & - & h_i (jpi,jpj,jpl) , a_i (jpi,jpj,jpl) , v_i (jpi,jpj,jpl) , & - & v_s (jpi,jpj,jpl) , h_s (jpi,jpj,jpl) , t_su (jpi,jpj,jpl) , & - & s_i (jpi,jpj,jpl) , sv_i (jpi,jpj,jpl) , o_i (jpi,jpj,jpl) , & - & oa_i (jpi,jpj,jpl) , bv_i (jpi,jpj,jpl) , STAT=ierr(ii) ) + ALLOCATE( u_ice_b(jpi,jpj) , v_ice_b(jpi,jpj) , STAT=ierr(ii) ) + ! * fluxes ii = ii + 1 - ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) , & - & vt_i (jpi,jpj) , vt_s (jpi,jpj) , st_i(jpi,jpj) , at_i(jpi,jpj) , ato_i(jpi,jpj) , & - & et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i(jpi,jpj) , tm_s(jpi,jpj) , & - & sm_i (jpi,jpj) , tm_su(jpi,jpj) , hm_i(jpi,jpj) , hm_s(jpi,jpj) , & - & om_i (jpi,jpj) , bvm_i(jpi,jpj) , tau_icebfr(jpi,jpj), icb_mask(jpi,jpj), STAT=ierr(ii) ) + ALLOCATE( wfx_res(jpi,jpj) , sfx_res(jpi,jpj) , hfx_res(jpi,jpj) , STAT=ierr(ii) ) ! full arrays since it is used in conjonction with global variables + + ! * ice rheology + ii = ii+1 + ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , & + & strength (jpi,jpj) , stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) , & + & aniso_11 (jpi,jpj) , aniso_12 (jpi,jpj) , rdg_conv (jpi,jpj) , & + & icb_mask (jpi,jpj) , STAT=ierr(ii) ) + ! * mean and total + ii = ii + 1 + ALLOCATE( vt_i (jpi,jpj) , vt_s (jpi,jpj) , at_i (jpi,jpj) , & ! full arrays since they are used in rheology + & vt_ip(jpi,jpj) , vt_il(jpi,jpj) , at_ip(jpi,jpj) , STAT=ierr(ii) ) + + ! * others ii = ii + 1 - ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) + ALLOCATE( t_bo(jpi,jpj) , rn_amax_2d(jpi,jpj) , STAT=ierr(ii) ) + + ! -------------------- ! + ! == REDUCED ARRAYS == ! + ! -------------------- ! + ! * Ice global state variables ii = ii + 1 - ALLOCATE( t_i(jpi,jpj,nlay_i,jpl) , e_i(jpi,jpj,nlay_i,jpl) , sz_i(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) ) + ALLOCATE( bv_i(A2D(0),jpl) , a_ip_frac(A2D(0),jpl) , a_ip_eff(A2D(0),jpl) , STAT=ierr(ii) ) + ! * Before values of global variables ii = ii + 1 - ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl), & - & v_il(jpi,jpj,jpl) , h_il(jpi,jpj,jpl) , a_ip_eff (jpi,jpj,jpl) , & - & dh_i_sum_2d(jpi,jpj,jpl) , dh_s_mlt_2d(jpi,jpj,jpl) , STAT = ierr(ii) ) + ALLOCATE( at_i_b(A2D(0)) , h_i_b (A2D(0),jpl) , a_i_b(A2D(0),jpl) , v_i_b(A2D(0),jpl) , & + & v_s_b (A2D(0),jpl) , h_s_b (A2D(0),jpl) , & + & v_ip_b(A2D(0),jpl) , v_il_b(A2D(0),jpl) , & + & sv_i_b(A2D(0),jpl) , e_i_b (A2D(0),nlay_i,jpl) , e_s_b(A2D(0),nlay_s,jpl) , STAT=ierr(ii) ) + ! * fluxes ii = ii + 1 - ALLOCATE( at_ip(jpi,jpj) , hm_ip(jpi,jpj) , vt_ip(jpi,jpj) , hm_il(jpi,jpj) , vt_il(jpi,jpj) , STAT = ierr(ii) ) + ALLOCATE( qsb_ice_bot(A2D(0)) , qlead (A2D(0)) , qt_atm_oi (A2D(0)) , qt_oce_ai (A2D(0)) , fhld (A2D(0)) , & + & wfx_snw_sni(A2D(0)) , wfx_snw (A2D(0)) , wfx_snw_dyn(A2D(0)) , wfx_snw_sum(A2D(0)) , wfx_snw_sub(A2D(0)) , & + & wfx_ice (A2D(0)) , wfx_sub (A2D(0)) , wfx_ice_sub(A2D(0)) , wfx_lam (A2D(0)) , & + & wfx_pnd (A2D(0)) , & + & wfx_bog (A2D(0)) , wfx_dyn (A2D(0)) , wfx_bom(A2D(0)) , wfx_sum(A2D(0)) , & + & wfx_sni (A2D(0)) , wfx_opw (A2D(0)) , wfx_spr(A2D(0)) , & + & & + & sfx_bri (A2D(0)) , sfx_dyn (A2D(0)) , sfx_sub(A2D(0)) , sfx_lam(A2D(0)) , & + & sfx_bog (A2D(0)) , sfx_bom (A2D(0)) , sfx_sum(A2D(0)) , sfx_sni(A2D(0)) , sfx_opw(A2D(0)) , & + & hfx_snw (A2D(0)) , hfx_sub (A2D(0)) , & + & hfx_sum (A2D(0)) , hfx_bom (A2D(0)) , hfx_bog(A2D(0)) , hfx_dif(A2D(0)) , & + & hfx_opw (A2D(0)) , hfx_thd (A2D(0)) , hfx_dyn(A2D(0)) , hfx_spr(A2D(0)) , & + & hfx_err_dif(A2D(0)) , wfx_err_sub(A2D(0)) , STAT=ierr(ii) ) + ii = ii + 1 + ALLOCATE( qtr_ice_bot(A2D(0),jpl) , cnd_ice(A2D(0),jpl) , t1_ice(A2D(0),jpl) , STAT=ierr(ii) ) + + ! * ice rheology + ii = ii+1 + ALLOCATE( delta_i(A2D(0)) , divu_i(A2D(0)) , shear_i(A2D(0)) , STAT=ierr(ii) ) - ! * Old values of global variables + ! * mean and total ii = ii + 1 - ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl) , h_i_b(jpi,jpj,jpl), & - & v_ip_b(jpi,jpj,jpl) , v_il_b(jpi,jpj,jpl) , & - & a_i_b (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) , & - & STAT=ierr(ii) ) + ALLOCATE( st_i (A2D(0)) , et_i (A2D(0)) , et_s(A2D(0)) , hm_i (A2D(0)) , & + & hm_ip(A2D(0)) , hm_il(A2D(0)) , tm_i(A2D(0)) , tm_s (A2D(0)) , & + & sm_i (A2D(0)) , hm_s (A2D(0)) , om_i(A2D(0)) , bvm_i(A2D(0)) , & + & tm_su(A2D(0)) , STAT=ierr(ii) ) + ! * others ii = ii + 1 - ALLOCATE( u_ice_b(jpi,jpj) , v_ice_b(jpi,jpj) , at_i_b(jpi,jpj) , STAT=ierr(ii) ) + ALLOCATE( tau_icebfr(A2D(0)) , dh_i_sum_2d(A2D(0),jpl) , dh_s_mlt_2d(A2D(0),jpl) , STAT=ierr(ii) ) + ii = 1 + ALLOCATE( ht_i_new (A2D(0)) , fraz_frac (A2D(0)) , STAT=ierr(ii) ) ! * Ice thickness distribution variables ii = ii + 1 @@ -536,19 +570,19 @@ CONTAINS ! * Ice diagnostics ii = ii + 1 - ALLOCATE( diag_trp_vi(jpi,jpj) , diag_trp_vs (jpi,jpj) , diag_trp_ei(jpi,jpj), & - & diag_trp_es(jpi,jpj) , diag_trp_sv (jpi,jpj) , diag_heat (jpi,jpj), & - & diag_sice (jpi,jpj) , diag_vice (jpi,jpj) , diag_vsnw (jpi,jpj), diag_aice(jpi,jpj), diag_vpnd(jpi,jpj), & - & diag_adv_mass(jpi,jpj), diag_adv_salt(jpi,jpj), diag_adv_heat(jpi,jpj), STAT=ierr(ii) ) + ALLOCATE( diag_trp_vi (A2D(0)) , diag_trp_vs (A2D(0)) , diag_trp_ei (A2D(0)) , & + & diag_trp_es (A2D(0)) , diag_trp_sv (A2D(0)) , diag_heat (A2D(0)) , & + & diag_sice (A2D(0)) , diag_vice (A2D(0)) , diag_vsnw (A2D(0)) , diag_aice(A2D(0)) , diag_vpnd(A2D(0)), & + & diag_adv_mass(A2D(0)) , diag_adv_salt(A2D(0)) , diag_adv_heat(A2D(0)) , STAT=ierr(ii) ) ! * Ice conservation ii = ii + 1 - ALLOCATE( diag_v (jpi,jpj) , diag_s (jpi,jpj) , diag_t (jpi,jpj), & - & diag_fv(jpi,jpj) , diag_fs(jpi,jpj) , diag_ft(jpi,jpj), STAT=ierr(ii) ) + ALLOCATE( diag_v (A2D(0)) , diag_s (A2D(0)) , diag_t (A2D(0)), & + & diag_fv(A2D(0)) , diag_fs(A2D(0)) , diag_ft(A2D(0)), STAT=ierr(ii) ) ! * SIMIP diagnostics ii = ii + 1 - ALLOCATE( t_si(jpi,jpj,jpl) , tm_si(jpi,jpj) , qcn_ice_bot(jpi,jpj,jpl) , qcn_ice_top(jpi,jpj,jpl) , STAT = ierr(ii) ) + ALLOCATE( t_si(A2D(0),jpl) , tm_si(A2D(0)) , qcn_ice_bot(A2D(0),jpl) , qcn_ice_top(A2D(0),jpl) , STAT = ierr(ii) ) ice_alloc = MAXVAL( ierr(:) ) IF( ice_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_alloc: failed to allocate arrays.' ) diff --git a/src/ICE/icealb.F90 b/src/ICE/icealb.F90 index 7a7b3e42af1420de1b15357108daf681858dbdc3..af7e868657a385de80f4030979f09463adac5813 100644 --- a/src/ICE/icealb.F90 +++ b/src/ICE/icealb.F90 @@ -48,7 +48,7 @@ MODULE icealb !!---------------------------------------------------------------------- CONTAINS - SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, pcloud_fra, palb_ice ) + SUBROUTINE ice_alb( ld_pnd_alb, pt_su, ph_ice, ph_snw, pafrac_pnd, ph_pnd, pcloud_fra, palb_ice ) !!---------------------------------------------------------------------- !! *** ROUTINE ice_alb *** !! @@ -94,16 +94,16 @@ CONTAINS !! Brandt et al. 2005, J. Climate, vol 18 !! Grenfell & Perovich 2004, JGR, vol 109 !!---------------------------------------------------------------------- - REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pt_su ! ice surface temperature (Kelvin) - REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: ph_ice ! sea-ice thickness - REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: ph_snw ! snow depth - LOGICAL , INTENT(in ) :: ld_pnd_alb ! effect of melt ponds on albedo - REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pafrac_pnd ! melt pond relative fraction (per unit ice area) - REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: ph_pnd ! melt pond depth - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pcloud_fra ! cloud fraction - REAL(wp), INTENT( out), DIMENSION(:,:,:) :: palb_ice ! albedo of ice + LOGICAL , INTENT(in ) :: ld_pnd_alb ! effect of melt ponds on albedo + REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: pt_su ! ice surface temperature (Kelvin) + REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: ph_ice ! sea-ice thickness + REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: ph_snw ! snow depth + REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: pafrac_pnd ! melt pond relative fraction (per unit ice area) + REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: ph_pnd ! melt pond depth + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pcloud_fra ! cloud fraction + REAL(wp), INTENT( out), DIMENSION(A2D(0),jpl) :: palb_ice ! albedo of ice ! - REAL(wp), DIMENSION(jpi,jpj,jpl) :: za_s_fra ! ice fraction covered by snow + REAL(wp), DIMENSION(A2D(0),jpl) :: za_s_fra ! ice fraction covered by snow INTEGER :: ji, jj, jl ! dummy loop indices REAL(wp) :: z1_c1, z1_c2,z1_c3, z1_c4 ! local scalar REAL(wp) :: z1_href_pnd ! inverse of the characteristic length scale (Lecomte et al. 2015) @@ -121,10 +121,10 @@ CONTAINS z1_c3 = 1._wp / 0.02_wp z1_c4 = 1._wp / 0.03_wp ! - CALL ice_var_snwfra( ph_snw, za_s_fra ) ! calculate ice fraction covered by snow + CALL ice_var_snwfra( ph_snw(:,:,:), za_s_fra(:,:,:) ) ! calculate ice fraction covered by snow ! DO jl = 1, jpl - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! palb_ice used over the full domain in icesbc + DO_2D( 0, 0, 0, 0 ) ! palb_ice used over the full domain in icesbc ! !---------------------------------------------! !--- Specific snow, ice and pond fractions ---! @@ -164,10 +164,10 @@ CONTAINS zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd ) ! ! !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions - zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) + zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * smask0(ji,jj) ! zalb_cs = zalb_os - ( - 0.1010_wp * zalb_os * zalb_os & - & + 0.1933_wp * zalb_os - 0.0148_wp ) * tmask(ji,jj,1) + & + 0.1933_wp * zalb_os - 0.0148_wp ) * smask0(ji,jj) ! ! albedo depends on cloud fraction because of non-linear spectral effects palb_ice(ji,jj,jl) = ( 1._wp - pcloud_fra(ji,jj) ) * zalb_cs + pcloud_fra(ji,jj) * zalb_os diff --git a/src/ICE/icectl.F90 b/src/ICE/icectl.F90 index 78fb1563e11e09a7182939287a6e4381a3182e74..d2057625db3b42caa595134caaaa5dc68d355820 100644 --- a/src/ICE/icectl.F90 +++ b/src/ICE/icectl.F90 @@ -83,25 +83,33 @@ CONTAINS CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine REAL(wp) , INTENT(inout) :: pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft !! + INTEGER :: ji, jj, jl ! dummy loop index REAL(wp) :: zdiag_mass, zdiag_salt, zdiag_heat - REAL(wp), DIMENSION(jpi,jpj,10) :: ztmp3 - REAL(wp), DIMENSION(jpi,jpj,jpl,8) :: ztmp4 - REAL(wp), DIMENSION(10) :: zchk3 - REAL(wp), DIMENSION(8) :: zchk4 + REAL(wp), DIMENSION(A2D(0),10) :: ztmp3 + REAL(wp), DIMENSION(A2D(0),jpl,8) :: ztmp4 + REAL(wp), DIMENSION(10) :: zchk3 + REAL(wp), DIMENSION(8) :: zchk4 !!------------------------------------------------------------------- ! - ! -- quantities -- ! - ztmp3(:,:,1) = SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) * e1e2t ! volume - ztmp3(:,:,2) = SUM( sv_i * rhoi, dim=3 ) * e1e2t ! salt - ztmp3(:,:,3) = ( SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) ) * e1e2t ! heat - ! - ! -- fluxes -- ! - ztmp3(:,:,4) = ( wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd & ! mass - & + wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr ) * e1e2t - ztmp3(:,:,5) = ( sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw & ! salt - & + sfx_res + sfx_dyn + sfx_sub + sfx_lam ) * e1e2t - ztmp3(:,:,6) = ( hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & ! heat - & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) * e1e2t + DO_2D( 0, 0, 0, 0 ) + ! -- quantities -- ! + ztmp3(ji,jj,1) = SUM( v_i(ji,jj,:) * rhoi + v_s(ji,jj,:) * rhos + & + & ( v_ip(ji,jj,:) + v_il(ji,jj,:) ) * rhow ) * e1e2t(ji,jj) ! volume + ztmp3(ji,jj,2) = SUM( sv_i(ji,jj,:) * rhoi ) * e1e2t(ji,jj) ! salt + ztmp3(ji,jj,3) = ( SUM( SUM( e_i(ji,jj,:,:), dim=2 ) ) + & ! heat + & SUM( SUM( e_s(ji,jj,:,:), dim=2 ) ) ) * e1e2t(ji,jj) + ! + ! -- fluxes -- ! + ztmp3(ji,jj,4) = ( wfx_bog (ji,jj) + wfx_bom (ji,jj) + wfx_sum (ji,jj) + wfx_sni (ji,jj) & ! mass + & + wfx_opw (ji,jj) + wfx_res (ji,jj) + wfx_dyn (ji,jj) + wfx_lam (ji,jj) + wfx_pnd(ji,jj) & + & + wfx_snw_sni(ji,jj) + wfx_snw_sum(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sub(ji,jj) & + & + wfx_ice_sub(ji,jj) + wfx_spr(ji,jj) ) * e1e2t(ji,jj) + ztmp3(ji,jj,5) = ( sfx_bri(ji,jj) + sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj) & ! salt + & + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) ) * e1e2t(ji,jj) + ztmp3(ji,jj,6) = ( hfx_sum(ji,jj) + hfx_bom(ji,jj) + hfx_bog(ji,jj) + hfx_dif(ji,jj) + hfx_opw(ji,jj) + hfx_snw(ji,jj) & ! heat + & - hfx_thd(ji,jj) - hfx_dyn(ji,jj) - hfx_res(ji,jj) - hfx_sub(ji,jj) - hfx_spr(ji,jj) ) * e1e2t(ji,jj) + ! + END_2D ! ! -- global sum -- ! zchk3(1:6) = glob_sum_vec( 'icectl', ztmp3(:,:,1:6) ) @@ -123,25 +131,33 @@ CONTAINS zdiag_heat = ( zchk3(3) - pdiag_t ) * r1_Dt_ice + ( zchk3(6) - pdiag_ft ) ! -- max concentration diag -- ! - ztmp3(:,:,7) = SUM( a_i, dim=3 ) - zchk3(7) = glob_max( 'icectl', ztmp3(:,:,7) ) - + DO_2D( 0, 0, 0, 0 ) + ztmp3(ji,jj,7) = SUM( a_i(ji,jj,:) ) + END_2D + zchk3(7) = glob_max( 'icectl', ztmp3(:,:,7) ) + ! -- advection scheme is conservative? -- ! - ztmp3(:,:,8 ) = diag_adv_mass * e1e2t - ztmp3(:,:,9 ) = diag_adv_heat * e1e2t - ztmp3(:,:,10) = SUM( a_i + epsi10, dim=3 ) * e1e2t ! ice area (+epsi10 to set a threshold > 0 when there is no ice) - zchk3(8:10) = glob_sum_vec( 'icectl', ztmp3(:,:,8:10) ) + DO_2D( 0, 0, 0, 0 ) + ztmp3(ji,jj,8 ) = diag_adv_mass(ji,jj) * e1e2t(ji,jj) + ztmp3(ji,jj,9 ) = diag_adv_heat(ji,jj) * e1e2t(ji,jj) + ztmp3(ji,jj,10) = SUM( a_i(ji,jj,:) + epsi10 ) * e1e2t(ji,jj) ! ice area (+epsi10 to set a threshold > 0 when there is no ice) + END_2D + zchk3(8:10) = glob_sum_vec( 'icectl', ztmp3(:,:,8:10) ) ! -- min diags -- ! - ztmp4(:,:,:,1) = v_i - ztmp4(:,:,:,2) = v_s - ztmp4(:,:,:,3) = v_ip - ztmp4(:,:,:,4) = v_il - ztmp4(:,:,:,5) = a_i - ztmp4(:,:,:,6) = sv_i - ztmp4(:,:,:,7) = SUM( e_i, dim=3 ) - ztmp4(:,:,:,8) = SUM( e_s, dim=3 ) - zchk4(1:8) = glob_min_vec( 'icectl', ztmp4(:,:,:,1:8) ) + DO jl = 1, jpl + DO_2D( 0, 0, 0, 0 ) + ztmp4(ji,jj,jl,1) = v_i(ji,jj,jl) + ztmp4(ji,jj,jl,2) = v_s(ji,jj,jl) + ztmp4(ji,jj,jl,3) = v_ip(ji,jj,jl) + ztmp4(ji,jj,jl,4) = v_il(ji,jj,jl) + ztmp4(ji,jj,jl,5) = a_i(ji,jj,jl) + ztmp4(ji,jj,jl,6) = sv_i(ji,jj,jl) + ztmp4(ji,jj,jl,7) = SUM( e_i(ji,jj,:,jl) ) + ztmp4(ji,jj,jl,8) = SUM( e_s(ji,jj,:,jl) ) + END_2D + ENDDO + zchk4(1:8) = glob_min_vec( 'icectl', ztmp4(:,:,:,1:8) ) IF( lwp ) THEN ! check conservation issues @@ -188,17 +204,21 @@ CONTAINS !!------------------------------------------------------------------- CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine !! - REAL(wp), DIMENSION(jpi,jpj,4) :: ztmp - REAL(wp), DIMENSION(4) :: zchk + INTEGER :: ji, jj ! dummy loop index + REAL(wp), DIMENSION(A2D(0),4) :: ztmp + REAL(wp), DIMENSION(4) :: zchk !!------------------------------------------------------------------- - - ztmp(:,:,1) = ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + wfx_pnd + diag_vice + diag_vsnw + diag_vpnd - diag_adv_mass ) * e1e2t ! mass diag - ztmp(:,:,2) = ( sfx + diag_sice - diag_adv_salt ) * e1e2t ! salt - ztmp(:,:,3) = ( qt_oce_ai - qt_atm_oi + diag_heat - diag_adv_heat ) * e1e2t ! heat - ! equivalent to this: - !! ( -diag_heat + hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & - !! & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) * e1e2t ) - ztmp(:,:,4) = SUM( a_i + epsi10, dim=3 ) * e1e2t ! ice area (+epsi10 to set a threshold > 0 when there is no ice) + DO_2D( 0, 0, 0, 0 ) + ! + ztmp(ji,jj,1) = ( wfx_ice (ji,jj) + wfx_snw (ji,jj) + wfx_pnd (ji,jj) + wfx_spr(ji,jj) + wfx_sub(ji,jj) & + & + diag_vice(ji,jj) + diag_vsnw(ji,jj) + diag_vpnd(ji,jj) - diag_adv_mass(ji,jj) ) * e1e2t(ji,jj) ! mass diag + ztmp(ji,jj,2) = ( sfx(ji,jj) + diag_sice(ji,jj) - diag_adv_salt(ji,jj) ) * e1e2t(ji,jj) ! salt + ztmp(ji,jj,3) = ( qt_oce_ai(ji,jj) - qt_atm_oi(ji,jj) + diag_heat(ji,jj) - diag_adv_heat(ji,jj) ) * e1e2t(ji,jj) ! heat + ! equivalent to this: + !! ( -diag_heat + hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & + !! & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) * e1e2t ) + ztmp(ji,jj,4) = SUM( a_i(ji,jj,:) + epsi10 ) * e1e2t(ji,jj) ! ice area (+epsi10 to set a threshold > 0 when there is no ice) + END_2D ! global sums zchk(1:4) = glob_sum_vec( 'icectl', ztmp(:,:,1:4) ) @@ -226,11 +246,11 @@ CONTAINS !!------------------------------------------------------------------- INTEGER , INTENT(in) :: icount ! called at: =0 the begining of the routine, =1 the end CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine - REAL(wp) , DIMENSION(jpi,jpj), INTENT(inout) :: pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft + REAL(wp) , DIMENSION(A2D(0)), INTENT(inout) :: pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft !! - REAL(wp), DIMENSION(jpi,jpj) :: zdiag_mass, zdiag_salt, zdiag_heat, & - & zdiag_amin, zdiag_vmin, zdiag_smin, zdiag_emin !!, zdiag_amax - INTEGER :: jl, jk + REAL(wp), DIMENSION(A2D(0)) :: zdiag_mass, zdiag_salt, zdiag_heat, & + & zdiag_amin, zdiag_vmin, zdiag_smin, zdiag_emin !!, zdiag_amax + INTEGER :: ji, jj, jl, jk LOGICAL :: ll_stop_m = .FALSE. LOGICAL :: ll_stop_s = .FALSE. LOGICAL :: ll_stop_t = .FALSE. @@ -239,62 +259,79 @@ CONTAINS ! IF( icount == 0 ) THEN - pdiag_v = SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) - pdiag_s = SUM( sv_i * rhoi , dim=3 ) - pdiag_t = SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) + DO_2D( 0, 0, 0, 0 ) + pdiag_v(ji,jj) = SUM( v_i(ji,jj,:) * rhoi + v_s(ji,jj,:) * rhos + ( v_ip(ji,jj,:) + v_il(ji,jj,:) ) * rhow ) + pdiag_s(ji,jj) = SUM( sv_i(ji,jj,:) * rhoi ) + pdiag_t(ji,jj) = SUM( SUM( e_i(ji,jj,:,:), dim=2 ) ) + SUM( SUM( e_s(ji,jj,:,:), dim=2 ) ) ! mass flux - pdiag_fv = wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd + & - & wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr + pdiag_fv(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) & + & + wfx_opw(ji,jj) + wfx_res(ji,jj) + wfx_dyn(ji,jj) + wfx_lam(ji,jj) + wfx_pnd (ji,jj) & + & + wfx_snw_sni(ji,jj) + wfx_snw_sum(ji,jj) + wfx_snw_dyn(ji,jj) & + & + wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) + wfx_spr(ji,jj) ! salt flux - pdiag_fs = sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw + sfx_res + sfx_dyn + sfx_sub + sfx_lam + pdiag_fs(ji,jj) = sfx_bri(ji,jj) + sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) & + & + sfx_opw(ji,jj) + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) ! heat flux - pdiag_ft = hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & - & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr + pdiag_ft(ji,jj) = hfx_sum(ji,jj) + hfx_bom(ji,jj) + hfx_bog(ji,jj) + hfx_dif(ji,jj) + hfx_opw(ji,jj) + hfx_snw(ji,jj) & + & - hfx_thd(ji,jj) - hfx_dyn(ji,jj) - hfx_res(ji,jj) - hfx_sub(ji,jj) - hfx_spr(ji,jj) + END_2D ELSEIF( icount == 1 ) THEN - + ! -- mass diag -- ! - zdiag_mass = ( SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) - pdiag_v ) * r1_Dt_ice & - & + ( wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd + & - & wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr ) & - & - pdiag_fv + DO_2D( 0, 0, 0, 0 ) + zdiag_mass(ji,jj) = ( SUM( v_i(ji,jj,:) * rhoi + v_s(ji,jj,:) * rhos & + & + ( v_ip(ji,jj,:) + v_il(ji,jj,:) ) * rhow ) - pdiag_v(ji,jj) ) * r1_Dt_ice & + & + ( wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) + wfx_opw(ji,jj) & + & + wfx_res(ji,jj) + wfx_dyn(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj) & + & + wfx_snw_sni(ji,jj) + wfx_snw_sum(ji,jj) + wfx_snw_dyn(ji,jj) & + & + wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) + wfx_spr(ji,jj) ) & + & - pdiag_fv(ji,jj) + END_2D IF( MAXVAL( ABS(zdiag_mass) ) > rchk_m * rn_icechk_cel ) ll_stop_m = .TRUE. ! ! -- salt diag -- ! - zdiag_salt = ( SUM( sv_i * rhoi , dim=3 ) - pdiag_s ) * r1_Dt_ice & - & + ( sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw + sfx_res + sfx_dyn + sfx_sub + sfx_lam ) & - & - pdiag_fs + DO_2D( 0, 0, 0, 0 ) + zdiag_salt(ji,jj) = ( SUM( sv_i(ji,jj,:) * rhoi ) - pdiag_s(ji,jj) ) * r1_Dt_ice & + & + ( sfx_bri(ji,jj) + sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) & + & + sfx_opw(ji,jj) + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) ) & + & - pdiag_fs(ji,jj) + END_2D IF( MAXVAL( ABS(zdiag_salt) ) > rchk_s * rn_icechk_cel ) ll_stop_s = .TRUE. ! ! -- heat diag -- ! - zdiag_heat = ( SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) - pdiag_t ) * r1_Dt_ice & - & + ( hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & - & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) & - & - pdiag_ft + DO_2D( 0, 0, 0, 0 ) + zdiag_heat(ji,jj) = ( SUM( SUM( e_i(ji,jj,:,:), dim=2 ) ) & + & + SUM( SUM( e_s(ji,jj,:,:), dim=2 ) ) - pdiag_t(ji,jj) ) * r1_Dt_ice & + & + ( hfx_sum(ji,jj) + hfx_bom(ji,jj) + hfx_bog(ji,jj) & + & + hfx_dif(ji,jj) + hfx_opw(ji,jj) + hfx_snw(ji,jj) & + & - hfx_thd(ji,jj) - hfx_dyn(ji,jj) - hfx_res(ji,jj) - hfx_sub(ji,jj) - hfx_spr(ji,jj) ) & + & - pdiag_ft(ji,jj) + END_2D IF( MAXVAL( ABS(zdiag_heat) ) > rchk_t * rn_icechk_cel ) ll_stop_t = .TRUE. ! ! -- other diags -- ! ! a_i < 0 zdiag_amin(:,:) = 0._wp DO jl = 1, jpl - WHERE( a_i(:,:,jl) < 0._wp ) zdiag_amin(:,:) = 1._wp + WHERE( a_i(A2D(0),jl) < 0._wp ) zdiag_amin(:,:) = 1._wp ENDDO ! v_i < 0 zdiag_vmin(:,:) = 0._wp DO jl = 1, jpl - WHERE( v_i(:,:,jl) < 0._wp ) zdiag_vmin(:,:) = 1._wp + WHERE( v_i(A2D(0),jl) < 0._wp ) zdiag_vmin(:,:) = 1._wp ENDDO ! s_i < 0 zdiag_smin(:,:) = 0._wp DO jl = 1, jpl - WHERE( s_i(:,:,jl) < 0._wp ) zdiag_smin(:,:) = 1._wp + WHERE( s_i(A2D(0),jl) < 0._wp ) zdiag_smin(:,:) = 1._wp ENDDO ! e_i < 0 zdiag_emin(:,:) = 0._wp DO jl = 1, jpl DO jk = 1, nlay_i - WHERE( e_i(:,:,jk,jl) < 0._wp ) zdiag_emin(:,:) = 1._wp + WHERE( e_i(A2D(0),jk,jl) < 0._wp ) zdiag_emin(:,:) = 1._wp ENDDO ENDDO ! a_i > amax @@ -751,8 +788,9 @@ CONTAINS !!------------------------------------------------------------------- INTEGER, INTENT(in) :: kt ! ice time-step index ! - REAL(wp), DIMENSION(jpi,jpj,6) :: ztmp - REAL(wp), DIMENSION(6) :: zchk + INTEGER :: ji, jj ! dummy loop index + REAL(wp), DIMENSION(A2D(0),6) :: ztmp + REAL(wp), DIMENSION(6) :: zchk !!------------------------------------------------------------------- ! IF( kt == nit000 .AND. lwp ) THEN @@ -762,25 +800,27 @@ CONTAINS ENDIF ! ! -- 2D budgets (must be close to 0) -- ! - ztmp(:,:,1) = wfx_ice (:,:) + wfx_snw (:,:) + wfx_spr (:,:) + wfx_sub(:,:) + wfx_pnd(:,:) & - & + diag_vice(:,:) + diag_vsnw(:,:) + diag_vpnd(:,:) - diag_adv_mass(:,:) - ztmp(:,:,2) = sfx(:,:) + diag_sice(:,:) - diag_adv_salt(:,:) - ztmp(:,:,3) = qt_oce_ai(:,:) - qt_atm_oi(:,:) + diag_heat(:,:) - diag_adv_heat(:,:) - + DO_2D( 0, 0, 0, 0 ) + ztmp(ji,jj,1) = wfx_ice (ji,jj) + wfx_snw (ji,jj) + wfx_spr (ji,jj) + wfx_sub(ji,jj) + wfx_pnd(ji,jj) & + & + diag_vice(ji,jj) + diag_vsnw(ji,jj) + diag_vpnd(ji,jj) - diag_adv_mass(ji,jj) + ztmp(ji,jj,2) = sfx(ji,jj) + diag_sice(ji,jj) - diag_adv_salt(ji,jj) + ztmp(ji,jj,3) = qt_oce_ai(ji,jj) - qt_atm_oi(ji,jj) + diag_heat(ji,jj) - diag_adv_heat(ji,jj) + END_2D ! write outputs CALL iom_put( 'icedrift_mass', ztmp(:,:,1) ) CALL iom_put( 'icedrift_salt', ztmp(:,:,2) ) CALL iom_put( 'icedrift_heat', ztmp(:,:,3) ) ! -- 1D budgets -- ! - ztmp(:,:,1) = ztmp(:,:,1) * e1e2t * rDt_ice ! mass - ztmp(:,:,2) = ztmp(:,:,2) * e1e2t * rDt_ice * 1.e-3 ! salt - ztmp(:,:,3) = ztmp(:,:,3) * e1e2t ! heat - - ztmp(:,:,4) = diag_adv_mass * e1e2t * rDt_ice - ztmp(:,:,5) = diag_adv_salt * e1e2t * rDt_ice * 1.e-3 - ztmp(:,:,6) = diag_adv_heat * e1e2t - + DO_2D( 0, 0, 0, 0 ) + ztmp(ji,jj,1) = ztmp(ji,jj,1) * e1e2t(ji,jj) * rDt_ice ! mass + ztmp(ji,jj,2) = ztmp(ji,jj,2) * e1e2t(ji,jj) * rDt_ice * 1.e-3 ! salt + ztmp(ji,jj,3) = ztmp(ji,jj,3) * e1e2t(ji,jj) ! heat + + ztmp(ji,jj,4) = diag_adv_mass(ji,jj) * e1e2t(ji,jj) * rDt_ice + ztmp(ji,jj,5) = diag_adv_salt(ji,jj) * e1e2t(ji,jj) * rDt_ice * 1.e-3 + ztmp(ji,jj,6) = diag_adv_heat(ji,jj) * e1e2t(ji,jj) + END_2D ! global sums zchk(1:6) = glob_sum_vec( 'icectl', ztmp(:,:,1:6) ) diff --git a/src/ICE/icedia.F90 b/src/ICE/icedia.F90 index 154d89de1e4311b194a31b1e645aa65cf523a6d9..197a6a6c7508052c03e988d712c1eab81d8d77cc 100644 --- a/src/ICE/icedia.F90 +++ b/src/ICE/icedia.F90 @@ -33,6 +33,9 @@ MODULE icedia PUBLIC ice_dia ! called by icestp.F90 PUBLIC ice_dia_init ! called in icestp.F90 + !! * Substitutions +# include "do_loop_substitute.h90" + REAL(wp), SAVE :: r1_area ! inverse of the ocean area REAL(wp), DIMENSION(:,:), ALLOCATABLE :: vol_loc_ini, sal_loc_ini, tem_loc_ini ! initial volume, salt and heat contents REAL(wp) :: frc_sal, frc_voltop, frc_volbot, frc_temtop, frc_tembot ! global forcing trends @@ -48,7 +51,7 @@ CONTAINS !!---------------------------------------------------------------------! !! *** ROUTINE ice_dia_alloc *** !!---------------------------------------------------------------------! - ALLOCATE( vol_loc_ini(jpi,jpj), sal_loc_ini(jpi,jpj), tem_loc_ini(jpi,jpj), STAT=ice_dia_alloc ) + ALLOCATE( vol_loc_ini(A2D(0)), sal_loc_ini(A2D(0)), tem_loc_ini(A2D(0)), STAT=ice_dia_alloc ) CALL mpp_sum ( 'icedia', ice_dia_alloc ) IF( ice_dia_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_dia_alloc: failed to allocate arrays' ) @@ -64,8 +67,9 @@ CONTAINS !!--------------------------------------------------------------------------- INTEGER, INTENT(in) :: kt ! ocean time step !! - REAL(wp), DIMENSION(jpi,jpj,16) :: ztmp - REAL(wp), DIMENSION(16) :: zbg + INTEGER :: ji, jj ! dummy loop index + REAL(wp), DIMENSION(A2D(0),16) :: ztmp + REAL(wp), DIMENSION(16) :: zbg !!--------------------------------------------------------------------------- IF( ln_timing ) CALL timing_start('ice_dia') @@ -85,31 +89,32 @@ CONTAINS ! 1 - Trends due to forcing ! ! ---------------------------! ! they must be kept outside an IF(iom_use) because of the call to dia_rst below - ztmp(:,:,1) = - ( wfx_ice(:,:) + wfx_snw(:,:) + wfx_err_sub(:,:) ) * e1e2t(:,:) ! freshwater flux ice/snow-ocean - ztmp(:,:,2) = - ( wfx_sub(:,:) + wfx_spr(:,:) ) * e1e2t(:,:) ! freshwater flux ice/snow-atm - ztmp(:,:,3) = - sfx (:,:) * e1e2t(:,:) ! salt fluxes ice/snow-ocean - ztmp(:,:,4) = qt_atm_oi(:,:) * e1e2t(:,:) ! heat on top of ice-ocean - ztmp(:,:,5) = qt_oce_ai(:,:) * e1e2t(:,:) ! heat on top of ocean (and below ice) - + DO_2D( 0, 0, 0, 0 ) + ztmp(ji,jj,1) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) ) * e1e2t(ji,jj) ! freshwater flux ice/snow-ocean + ztmp(ji,jj,2) = - ( wfx_sub(ji,jj) + wfx_spr(ji,jj) ) * e1e2t(ji,jj) ! freshwater flux ice/snow-atm + ztmp(ji,jj,3) = - sfx (ji,jj) * e1e2t(ji,jj) ! salt fluxes ice/snow-ocean + ztmp(ji,jj,4) = qt_atm_oi(ji,jj) * e1e2t(ji,jj) ! heat on top of ice-ocean + ztmp(ji,jj,5) = qt_oce_ai(ji,jj) * e1e2t(ji,jj) ! heat on top of ocean (and below ice) + END_2D ! ----------------------- ! ! 2 - Contents ! ! ----------------------- ! - IF( iom_use('ibgvol_tot' ) ) ztmp(:,:,6 ) = vt_i (:,:) * e1e2t(:,:) ! ice volume - IF( iom_use('sbgvol_tot' ) ) ztmp(:,:,7 ) = vt_s (:,:) * e1e2t(:,:) ! snow volume - IF( iom_use('ibgarea_tot') ) ztmp(:,:,8 ) = at_i (:,:) * e1e2t(:,:) ! area - IF( iom_use('ibgsalt_tot') ) ztmp(:,:,9 ) = st_i (:,:) * e1e2t(:,:) ! salt content - IF( iom_use('ibgheat_tot') ) ztmp(:,:,10) = et_i (:,:) * e1e2t(:,:) ! heat content - IF( iom_use('sbgheat_tot') ) ztmp(:,:,11) = et_s (:,:) * e1e2t(:,:) ! heat content - IF( iom_use('ipbgvol_tot') ) ztmp(:,:,12) = vt_ip(:,:) * e1e2t(:,:) ! ice pond volume - IF( iom_use('ilbgvol_tot') ) ztmp(:,:,13) = vt_il(:,:) * e1e2t(:,:) ! ice pond lid volume + IF( iom_use('ibgvol_tot' ) ) ztmp(:,:,6 ) = vt_i (A2D(0)) * e1e2t(A2D(0)) ! ice volume + IF( iom_use('sbgvol_tot' ) ) ztmp(:,:,7 ) = vt_s (A2D(0)) * e1e2t(A2D(0)) ! snow volume + IF( iom_use('ibgarea_tot') ) ztmp(:,:,8 ) = at_i (A2D(0)) * e1e2t(A2D(0)) ! area + IF( iom_use('ibgsalt_tot') ) ztmp(:,:,9 ) = st_i (:,:) * e1e2t(A2D(0)) ! salt content + IF( iom_use('ibgheat_tot') ) ztmp(:,:,10) = et_i (:,:) * e1e2t(A2D(0)) ! heat content + IF( iom_use('sbgheat_tot') ) ztmp(:,:,11) = et_s (:,:) * e1e2t(A2D(0)) ! heat content + IF( iom_use('ipbgvol_tot') ) ztmp(:,:,12) = vt_ip(A2D(0)) * e1e2t(A2D(0)) ! ice pond volume + IF( iom_use('ilbgvol_tot') ) ztmp(:,:,13) = vt_il(A2D(0)) * e1e2t(A2D(0)) ! ice pond lid volume ! ---------------------------------- ! ! 3 - Content variations and drifts ! ! ---------------------------------- ! - IF( iom_use('ibgvolume') ) ztmp(:,:,14) = ( rhoi*vt_i(:,:) + rhos*vt_s(:,:) - vol_loc_ini(:,:) ) * e1e2t(:,:) ! freshwater trend - IF( iom_use('ibgsaltco') ) ztmp(:,:,15) = ( rhoi*st_i(:,:) - sal_loc_ini(:,:) ) * e1e2t(:,:) ! salt content trend + IF( iom_use('ibgvolume') ) ztmp(:,:,14) = ( rhoi*vt_i(A2D(0)) + rhos*vt_s(A2D(0)) - vol_loc_ini(:,:) ) * e1e2t(A2D(0)) ! freshwater trend + IF( iom_use('ibgsaltco') ) ztmp(:,:,15) = ( rhoi*st_i(:,:) - sal_loc_ini(:,:) ) * e1e2t(A2D(0)) ! salt content trend IF( iom_use('ibgheatco') .OR. iom_use('ibgheatfx') ) & - & ztmp(:,:,16) = ( et_i(:,:) + et_s(:,:) - tem_loc_ini(:,:) ) * e1e2t(:,:) ! heat content trend + & ztmp(:,:,16) = ( et_i(:,:) + et_s(:,:) - tem_loc_ini(:,:) ) * e1e2t(A2D(0)) ! heat content trend ! global sum zbg(1:16) = glob_sum_vec( 'icedia', ztmp(:,:,1:16) ) @@ -261,9 +266,9 @@ CONTAINS frc_tembot = 0._wp frc_sal = 0._wp ! record initial ice volume, salt and temp - vol_loc_ini(:,:) = rhoi * vt_i(:,:) + rhos * vt_s(:,:) ! ice/snow volume (kg/m2) - tem_loc_ini(:,:) = et_i(:,:) + et_s(:,:) ! ice/snow heat content (J) - sal_loc_ini(:,:) = rhoi * st_i(:,:) ! ice salt content (pss*kg/m2) + vol_loc_ini(:,:) = rhoi * vt_i(A2D(0)) + rhos * vt_s(A2D(0)) ! ice/snow volume (kg/m2) + tem_loc_ini(:,:) = et_i(:,:) + et_s(:,:) ! ice/snow heat content (J) + sal_loc_ini(:,:) = rhoi * st_i(:,:) ! ice salt content (pss*kg/m2) ENDIF ! ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file diff --git a/src/ICE/icedyn.F90 b/src/ICE/icedyn.F90 index dcbe3e77a3a7f6c9a6d9d37b2bc260c983736e6b..687cd916ed23110bcd9930e961649d6ab11dbe6a 100644 --- a/src/ICE/icedyn.F90 +++ b/src/ICE/icedyn.F90 @@ -93,8 +93,8 @@ CONTAINS ! ! retrieve thickness from volume for landfast param. and UMx advection scheme WHERE( a_i(:,:,:) >= epsi20 ) - h_i(:,:,:) = v_i(:,:,:) / a_i_b(:,:,:) - h_s(:,:,:) = v_s(:,:,:) / a_i_b(:,:,:) + h_i(:,:,:) = v_i(:,:,:) / a_i(:,:,:) + h_s(:,:,:) = v_s(:,:,:) / a_i(:,:,:) ELSEWHERE h_i(:,:,:) = 0._wp h_s(:,:,:) = 0._wp @@ -162,15 +162,12 @@ CONTAINS CASE ( np_dynADV1D , np_dynADV2D ) - ALLOCATE( zdivu_i(jpi,jpj) ) + ALLOCATE( zdivu_i(A2D(0)) ) DO_2D( 0, 0, 0, 0 ) zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) END_2D - CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1.0_wp ) - ! output CALL iom_put( 'icediv' , zdivu_i ) - DEALLOCATE( zdivu_i ) END SELECT diff --git a/src/ICE/icedyn_adv.F90 b/src/ICE/icedyn_adv.F90 index e2beb79a2b6d1d5801210c269b716259a8ec7823..a6d2e957735e1c0663619f52f663e237f61c3215 100644 --- a/src/ICE/icedyn_adv.F90 +++ b/src/ICE/icedyn_adv.F90 @@ -41,6 +41,8 @@ MODULE icedyn_adv ! ** namelist (namdyn_adv) ** INTEGER :: nn_UMx ! order of the UMx advection scheme ! + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/ICE 4.0 , NEMO Consortium (2018) !! $Id: icedyn_adv.F90 13472 2020-09-16 13:05:19Z smasson $ @@ -92,11 +94,11 @@ CONTAINS !------------ ! diagnostics !------------ - diag_trp_ei(:,:) = SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_Dt_ice - diag_trp_es(:,:) = SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_Dt_ice - diag_trp_sv(:,:) = SUM( sv_i(:,:,:) - sv_i_b(:,:,:) , dim=3 ) * r1_Dt_ice - diag_trp_vi(:,:) = SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_Dt_ice - diag_trp_vs(:,:) = SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_Dt_ice + diag_trp_ei(:,:) = SUM(SUM( e_i (A2D(0),1:nlay_i,:) - e_i_b (A2D(0),1:nlay_i,:), dim=4 ), dim=3 ) * r1_Dt_ice + diag_trp_es(:,:) = SUM(SUM( e_s (A2D(0),1:nlay_s,:) - e_s_b (A2D(0),1:nlay_s,:), dim=4 ), dim=3 ) * r1_Dt_ice + diag_trp_sv(:,:) = SUM( sv_i(A2D(0),:) - sv_i_b(A2D(0),:) , dim=3 ) * r1_Dt_ice + diag_trp_vi(:,:) = SUM( v_i (A2D(0),:) - v_i_b (A2D(0),:) , dim=3 ) * r1_Dt_ice + diag_trp_vs(:,:) = SUM( v_s (A2D(0),:) - v_s_b (A2D(0),:) , dim=3 ) * r1_Dt_ice IF( iom_use('icemtrp') ) CALL iom_put( 'icemtrp' , diag_trp_vi * rhoi ) ! ice mass transport IF( iom_use('snwmtrp') ) CALL iom_put( 'snwmtrp' , diag_trp_vs * rhos ) ! snw mass transport IF( iom_use('salmtrp') ) CALL iom_put( 'salmtrp' , diag_trp_sv * rhoi * 1.e-03 ) ! salt mass transport (kg/m2/s) diff --git a/src/ICE/icedyn_adv_pra.F90 b/src/ICE/icedyn_adv_pra.F90 index 28c12eb81037564fbadafa6a3f8ff8d1b217b875..54a90afdc79fcc2a8de05e609900434e5927a3b1 100644 --- a/src/ICE/icedyn_adv_pra.F90 +++ b/src/ICE/icedyn_adv_pra.F90 @@ -89,7 +89,7 @@ CONTAINS INTEGER :: icycle ! number of sub-timestep for the advection REAL(wp) :: zdt, z1_dt ! - - REAL(wp), DIMENSION(1) :: zcflprv, zcflnow ! for global communication - REAL(wp), DIMENSION(jpi,jpj) :: zati1, zati2 + REAL(wp), DIMENSION(A2D(0)) :: zati1, zati2 REAL(wp), DIMENSION(jpi,jpj) :: zudy, zvdx REAL(wp), DIMENSION(jpi,jpj,jpl) :: zhi_max, zhs_max, zhip_max, zs_i, zsi_max REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: ze_i, zei_max @@ -100,7 +100,7 @@ CONTAINS REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) :: z0es REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: z0ei !! diagnostics - REAL(wp), DIMENSION(jpi,jpj) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat + REAL(wp), DIMENSION(A2D(0)) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat !!---------------------------------------------------------------------- ! IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_pra: Prather advection scheme' @@ -129,8 +129,7 @@ CONTAINS END DO CALL icemax4D( ze_i , zei_max ) CALL icemax4D( ze_s , zes_max ) - CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1._wp ) - CALL lbc_lnk( 'icedyn_adv_pra', zes_max, 'T', 1._wp ) + CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1._wp, zes_max, 'T', 1._wp ) ! ! ! --- If ice drift is too fast, use subtime steps for advection (CFL test for stability) --- ! @@ -155,14 +154,14 @@ CONTAINS DO jt = 1, icycle ! diagnostics - zdiag_adv_mass(:,:) = SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & - & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow - zdiag_adv_salt(:,:) = SUM( psv_i(:,:,:) , dim=3 ) * rhoi - zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & - & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) + zdiag_adv_mass(:,:) = SUM( pv_i (A2D(0),:) , dim=3 ) * rhoi + SUM( pv_s (A2D(0),:) , dim=3 ) * rhos & + & + SUM( pv_ip(A2D(0),:) , dim=3 ) * rhow + SUM( pv_il(A2D(0),:) , dim=3 ) * rhow + zdiag_adv_salt(:,:) = SUM( psv_i(A2D(0),:) , dim=3 ) * rhoi + zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(A2D(0),1:nlay_i,:) , dim=4 ), dim=3 ) & + & - SUM(SUM( pe_s(A2D(0),1:nlay_s,:) , dim=4 ), dim=3 ) ! record at_i before advection (for open water) - zati1(:,:) = SUM( pa_i(:,:,:), dim=3 ) + zati1(:,:) = SUM( pa_i(A2D(0),:), dim=3 ) ! --- transported fields --- ! DO jl = 1, jpl @@ -275,8 +274,8 @@ CONTAINS & , z0oi , 'T', 1._wp, sxage , 'T', -1._wp, syage , 'T', -1._wp & ! ice age & , sxxage, 'T', 1._wp, syyage, 'T', 1._wp, sxyage, 'T', 1._wp ) CALL lbc_lnk( 'icedyn_adv_pra', z0es , 'T', 1._wp, sxc0 , 'T', -1._wp, syc0 , 'T', -1._wp & ! snw enthalpy - & , sxxc0 , 'T', 1._wp, syyc0 , 'T', 1._wp, sxyc0 , 'T', 1._wp ) - CALL lbc_lnk( 'icedyn_adv_pra', z0ei , 'T', 1._wp, sxe , 'T', -1._wp, sye , 'T', -1._wp & ! ice enthalpy + & , sxxc0 , 'T', 1._wp, syyc0 , 'T', 1._wp, sxyc0 , 'T', 1._wp & + & , z0ei , 'T', 1._wp, sxe , 'T', -1._wp, sye , 'T', -1._wp & ! ice enthalpy & , sxxe , 'T', 1._wp, syye , 'T', 1._wp, sxye , 'T', 1._wp ) IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN IF( ln_pnd_lids ) THEN @@ -317,7 +316,7 @@ CONTAINS END DO ! ! derive open water from ice concentration - zati2(:,:) = SUM( pa_i(:,:,:), dim=3 ) + zati2(:,:) = SUM( pa_i(A2D(0),:), dim=3 ) DO_2D( 0, 0, 0, 0 ) pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) & !--- open water & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt @@ -325,13 +324,13 @@ CONTAINS CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1.0_wp ) ! ! --- diagnostics --- ! - diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & - & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow & + diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i (A2D(0),:) , dim=3 ) * rhoi + SUM( pv_s (A2D(0),:) , dim=3 ) * rhos & + & + SUM( pv_ip(A2D(0),:) , dim=3 ) * rhow + SUM( pv_il(A2D(0),:) , dim=3 ) * rhow & & - zdiag_adv_mass(:,:) ) * z1_dt - diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(:,:,:) , dim=3 ) * rhoi & + diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(A2D(0),:) , dim=3 ) * rhoi & & - zdiag_adv_salt(:,:) ) * z1_dt - diag_adv_heat(:,:) = diag_adv_heat(:,:) + ( - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & - & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) & + diag_adv_heat(:,:) = diag_adv_heat(:,:) + ( - SUM(SUM( pe_i(A2D(0),1:nlay_i,:) , dim=4 ), dim=3 ) & + & - SUM(SUM( pe_s(A2D(0),1:nlay_s,:) , dim=4 ), dim=3 ) & & - zdiag_adv_heat(:,:) ) * z1_dt ! ! --- Ensure non-negative fields --- ! diff --git a/src/ICE/icedyn_adv_umx.F90 b/src/ICE/icedyn_adv_umx.F90 index e5113ac90de67aa1d107f9c1aea3275f2c71f9a2..d46b056b8fb94c4e8dbaaa5530e81e4390d050d8 100644 --- a/src/ICE/icedyn_adv_umx.F90 +++ b/src/ICE/icedyn_adv_umx.F90 @@ -104,7 +104,7 @@ CONTAINS ! REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zuv_ho, zvv_ho, zuv_ups, zvv_ups, z1_vi, z1_vs !! diagnostics - REAL(wp), DIMENSION(jpi,jpj) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat + REAL(wp), DIMENSION(A2D(0)) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat !!---------------------------------------------------------------------- ! IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_umx: Ultimate-Macho advection scheme' @@ -133,8 +133,7 @@ CONTAINS END DO CALL icemax4D( ze_i , zei_max ) CALL icemax4D( ze_s , zes_max ) - CALL lbc_lnk( 'icedyn_adv_umx', zei_max, 'T', 1._wp ) - CALL lbc_lnk( 'icedyn_adv_umx', zes_max, 'T', 1._wp ) + CALL lbc_lnk( 'icedyn_adv_umx', zei_max, 'T', 1._wp, zes_max, 'T', 1._wp ) ! ! ! --- If ice drift is too fast, use subtime steps for advection (CFL test for stability) --- ! @@ -182,11 +181,11 @@ CONTAINS DO jt = 1, icycle ! diagnostics - zdiag_adv_mass(:,:) = SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & - & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow - zdiag_adv_salt(:,:) = SUM( psv_i(:,:,:) , dim=3 ) * rhoi - zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & - & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) + zdiag_adv_mass(:,:) = SUM( pv_i (A2D(0),:) , dim=3 ) * rhoi + SUM( pv_s (A2D(0),:) , dim=3 ) * rhos & + & + SUM( pv_ip(A2D(0),:) , dim=3 ) * rhow + SUM( pv_il(A2D(0),:) , dim=3 ) * rhow + zdiag_adv_salt(:,:) = SUM( psv_i(A2D(0),:) , dim=3 ) * rhoi + zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(A2D(0),1:nlay_i,:) , dim=4 ), dim=3 ) & + & - SUM(SUM( pe_s(A2D(0),1:nlay_s,:) , dim=4 ), dim=3 ) ! record at_i before advection (for open water) zati1(:,:) = SUM( pa_i(:,:,:), dim=3 ) @@ -370,8 +369,7 @@ CONTAINS ELSE CALL lbc_lnk( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp ) ENDIF - CALL lbc_lnk( 'icedyn_adv_umx', pe_i, 'T', 1._wp ) - CALL lbc_lnk( 'icedyn_adv_umx', pe_s, 'T', 1._wp ) + CALL lbc_lnk( 'icedyn_adv_umx', pe_i, 'T', 1._wp, pe_s, 'T', 1._wp ) ! !== Open water area ==! zati2(:,:) = SUM( pa_i(:,:,:), dim=3 ) @@ -382,13 +380,13 @@ CONTAINS CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1._wp ) ! ! --- diagnostics --- ! - diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & - & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow & + diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i (A2D(0),:) , dim=3 ) * rhoi + SUM( pv_s (A2D(0),:) , dim=3 ) * rhos & + & + SUM( pv_ip(A2D(0),:) , dim=3 ) * rhow + SUM( pv_il(A2D(0),:) , dim=3 ) * rhow & & - zdiag_adv_mass(:,:) ) * z1_dt - diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(:,:,:) , dim=3 ) * rhoi & + diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(A2D(0),:) , dim=3 ) * rhoi & & - zdiag_adv_salt(:,:) ) * z1_dt - diag_adv_heat(:,:) = diag_adv_heat(:,:) + ( - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & - & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) & + diag_adv_heat(:,:) = diag_adv_heat(:,:) + ( - SUM(SUM( pe_i(A2D(0),1:nlay_i,:) , dim=4 ), dim=3 ) & + & - SUM(SUM( pe_s(A2D(0),1:nlay_s,:) , dim=4 ), dim=3 ) & & - zdiag_adv_heat(:,:) ) * z1_dt ! ! --- Ensure non-negative fields and in-bound thicknesses --- ! diff --git a/src/ICE/icedyn_rdgrft.F90 b/src/ICE/icedyn_rdgrft.F90 index 661748ea3b97e4f5e25f5780c8d29da6149ddc4d..edf8f8215b40cdeeecd9ecd973f3af14b61f9eb4 100644 --- a/src/ICE/icedyn_rdgrft.F90 +++ b/src/ICE/icedyn_rdgrft.F90 @@ -174,7 +174,7 @@ CONTAINS ! npti = 0 ; nptidx(:) = 0 ipti = 0 ; iptidx(:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF ( at_i(ji,jj) > epsi10 ) THEN npti = npti + 1 nptidx( npti ) = (jj - 1) * jpi + ji @@ -280,8 +280,15 @@ CONTAINS CALL ice_dyn_1d2d( 2 ) ! --- Move to 2D arrays --- ! ENDIF + ! clem: the 3 lbc below could be avoided if calculations above were performed over the full domain + ! but we think it is more efficient this way => to check? + CALL lbc_lnk( 'icedyn_rdgrft', ato_i , 'T', 1._wp ) + CALL lbc_lnk( 'icedyn_rdgrft', a_i , 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp, oa_i, 'T', 1._wp, & + & a_ip , 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp ) + CALL lbc_lnk( 'icedyn_rdgrft', e_i , 'T', 1._wp, e_s , 'T', 1._wp ) - CALL ice_var_agg( 1 ) + ! clem: I think we can comment this line but I am not sure it does not change results +!!$ CALL ice_var_agg( 1 ) ! controls IF( sn_cfctl%l_prtctl ) CALL ice_prt3D('icedyn_rdgrft') ! prints @@ -861,7 +868,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: ji, jj, jl ! dummy loop indices REAL(wp) :: z1_3 ! local scalars - REAL(wp), DIMENSION(jpi,jpj) :: zmsk, zworka ! temporary array used here + REAL(wp), DIMENSION(A2D(0)) :: zworka ! temporary array used here + REAL(wp), DIMENSION(jpi,jpj) :: zmsk ! temporary array used here !! LOGICAL :: ln_str_R75 REAL(wp) :: zhi, zcp @@ -886,7 +894,7 @@ CONTAINS ! ! Identify grid cells with ice npti = 0 ; nptidx(:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF ( at_i(ji,jj) > epsi10 ) THEN npti = npti + 1 nptidx( npti ) = (jj - 1) * jpi + ji @@ -956,12 +964,20 @@ CONTAINS CALL tab_1d_2d( npti, nptidx(1:npti), zstrength(1:npti), strength ) ! ENDIF + CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp ) ! this call could be removed if calculations were done on the full domain + ! ! but we decided it is more efficient this way ! CASE ( np_strh79 ) !== Hibler(1979)'s method ==! - strength(:,:) = rn_pstar * SUM( v_i(:,:,:), dim=3 ) * EXP( -rn_crhg * ( 1._wp - at_i(:,:) ) ) * zmsk(:,:) + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + strength(ji,jj) = rn_pstar * SUM( v_i(ji,jj,:) ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) * zmsk(ji,jj) + END_2D ! CASE ( np_strcst ) !== Constant strength ==! - strength(:,:) = rn_str * zmsk(:,:) + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + strength(ji,jj) = rn_str * zmsk(ji,jj) + END_2D ! END SELECT ! diff --git a/src/ICE/icedyn_rhg_eap.F90 b/src/ICE/icedyn_rhg_eap.F90 index 797ceba713de4241a41a013adc9add3387d9e756..7f3ac9e9a4e943a3616cb0bd3b48764c62a2e702 100644 --- a/src/ICE/icedyn_rhg_eap.F90 +++ b/src/ICE/icedyn_rhg_eap.F90 @@ -352,7 +352,6 @@ CONTAINS zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) END_2D - CALL lbc_lnk( 'icedyn_rhg_eap', tau_icebfr(:,:), 'T', 1.0_wp ) ! ELSE !-- no landfast DO_2D( 0, 0, 0, 0 ) @@ -810,9 +809,6 @@ CONTAINS IF( iom_use('utau_oi') .OR. iom_use('vtau_oi') .OR. iom_use('utau_ai') .OR. iom_use('vtau_ai') .OR. & & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN ! - CALL lbc_lnk( 'icedyn_rhg_eap', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, ztaux_ai, 'U', -1.0_wp, & - & ztauy_ai, 'V', -1.0_wp, ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) - ! CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) CALL iom_put( 'vtau_oi' , ztauy_oi * zmsk00 ) CALL iom_put( 'utau_ai' , ztaux_ai * zmsk00 ) @@ -894,9 +890,6 @@ CONTAINS ! --- yieldcurve --- ! IF( iom_use('yield11') .OR. iom_use('yield12') .OR. iom_use('yield22')) THEN - - CALL lbc_lnk( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp ) - CALL iom_put( 'yield11', zyield11 * zmsk00 ) CALL iom_put( 'yield22', zyield22 * zmsk00 ) CALL iom_put( 'yield12', zyield12 * zmsk00 ) @@ -904,18 +897,12 @@ CONTAINS ! --- anisotropy tensor --- ! IF( iom_use('aniso') ) THEN - CALL lbc_lnk( 'icedyn_rhg_eap', paniso_11, 'T', 1.0_wp ) CALL iom_put( 'aniso' , paniso_11 * zmsk00 ) ENDIF ! --- SIMIP --- ! IF( iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. & & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN - ! - CALL lbc_lnk( 'icedyn_rhg_eap', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & - & zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, & - & zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) - CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x) CALL iom_put( 'dssh_dy' , zspgV * zmsk00 ) ! Sea-surface tilt term in force balance (y) CALL iom_put( 'corstrx' , zCorU * zmsk00 ) ! Coriolis force term in force balance (x) @@ -946,10 +933,6 @@ CONTAINS END_2D - CALL lbc_lnk( 'icedyn_rhg_eap', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & - & zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & - & zdiag_xatrp , 'U', -1.0_wp, zdiag_yatrp , 'V', -1.0_wp ) - CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) CALL iom_put( 'ymtrpice' , zdiag_ymtrp_ice ) ! Y-component of sea-ice mass transport CALL iom_put( 'xmtrpsnw' , zdiag_xmtrp_snw ) ! X-component of snow mass transport (kg/s) diff --git a/src/ICE/icedyn_rhg_evp.F90 b/src/ICE/icedyn_rhg_evp.F90 index a260797a2a630a096e4e389072ab020f676c6a32..9e367e52a3888875f5d3df2171d46c000362f822 100644 --- a/src/ICE/icedyn_rhg_evp.F90 +++ b/src/ICE/icedyn_rhg_evp.F90 @@ -114,10 +114,10 @@ CONTAINS !! Bouillon et al., Ocean Modelling 2013 !! Kimmritz et al., Ocean Modelling 2016 & 2017 !!------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! time step - INTEGER , INTENT(in ) :: Kmm ! ocean time level index - REAL(wp), DIMENSION(:,:), INTENT(inout) :: pstress1_i, pstress2_i, pstress12_i ! - REAL(wp), DIMENSION(:,:), INTENT( out) :: pshear_i , pdivu_i , pdelta_i ! + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pstress1_i, pstress2_i, pstress12_i ! + REAL(wp), DIMENSION(A2D(0)), INTENT( out) :: pshear_i , pdivu_i , pdelta_i ! !! INTEGER :: ji, jj ! dummy loop indices INTEGER :: jter ! local integers @@ -135,38 +135,39 @@ CONTAINS ! REAL(wp) :: zfac_x, zfac_y ! - REAL(wp), DIMENSION(jpi,jpj) :: zdelta, zp_delt ! delta and P/delta at T points - REAL(wp), DIMENSION(jpi,jpj) :: zbeta ! beta coef from Kimmritz 2017 + REAL(wp), DIMENSION(jpi,jpj) :: zdelta, zp_delt ! delta, P/delta at T points + REAL(wp), DIMENSION(jpi,jpj) :: zbeta ! beta coef from Kimmritz 2017 ! - REAL(wp), DIMENSION(jpi,jpj) :: zdt_m ! (dt / ice-snow_mass) on T points - REAL(wp), DIMENSION(jpi,jpj) :: zaU , zaV ! ice fraction on U/V points - REAL(wp), DIMENSION(jpi,jpj) :: zmU_t, zmV_t ! (ice-snow_mass / dt) on U/V points - REAL(wp), DIMENSION(jpi,jpj) :: zmf ! coriolis parameter at T points - REAL(wp), DIMENSION(jpi,jpj) :: v_oceU, u_oceV, v_iceU, u_iceV ! ocean/ice u/v component on V/U points + REAL(wp), DIMENSION(jpi,jpj) :: zdt_m ! (dt / ice-snow_mass) on T points + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zaU , zaV ! ice fraction on U/V points + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zmU_t, zmV_t ! (ice-snow_mass / dt) on U/V points + REAL(wp), DIMENSION(jpi,jpj) :: zmf ! coriolis parameter at T points + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: v_oceU, u_oceV, v_iceU, u_iceV ! ocean/ice u/v component on V/U points ! - REAL(wp), DIMENSION(jpi,jpj) :: zds ! shear - REAL(wp), DIMENSION(jpi,jpj) :: zten_i, zshear ! tension, shear - REAL(wp), DIMENSION(jpi,jpj) :: zs1, zs2, zs12 ! stress tensor components - REAL(wp), DIMENSION(jpi,jpj) :: zsshdyn ! array used for the calculation of ice surface slope: - ! ! ocean surface (ssh_m) if ice is not embedded - ! ! ice bottom surface if ice is embedded - REAL(wp), DIMENSION(jpi,jpj) :: zfU , zfV ! internal stresses - REAL(wp), DIMENSION(jpi,jpj) :: zspgU, zspgV ! surface pressure gradient at U/V points - REAL(wp), DIMENSION(jpi,jpj) :: zCorU, zCorV ! Coriolis stress array - REAL(wp), DIMENSION(jpi,jpj) :: ztaux_ai, ztauy_ai ! ice-atm. stress at U-V points - REAL(wp), DIMENSION(jpi,jpj) :: ztaux_oi, ztauy_oi ! ice-ocean stress at U-V points - REAL(wp), DIMENSION(jpi,jpj) :: ztaux_bi, ztauy_bi ! ice-OceanBottom stress at U-V points (landfast) - REAL(wp), DIMENSION(jpi,jpj) :: ztaux_base, ztauy_base ! ice-bottom stress at U-V points (landfast) + REAL(wp), DIMENSION(jpi,jpj) :: zds ! shear + REAL(wp), DIMENSION(A2D(0)) :: zten_i, zshear ! tension, shear + REAL(wp), DIMENSION(jpi,jpj) :: zs1, zs2, zs12 ! stress tensor components + REAL(wp), DIMENSION(jpi,jpj) :: zsshdyn ! array used for the calculation of ice surface slope: + ! ! ocean surface (ssh_m) if ice is not embedded + ! ! ice bottom surface if ice is embedded + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zfU , zfV ! internal stresses + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zspgU, zspgV ! surface pressure gradient at U/V points + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zCorU, zCorV ! Coriolis stress array + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztaux_ai, ztauy_ai ! ice-atm. stress at U-V points + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztaux_oi, ztauy_oi ! ice-ocean stress at U-V points + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztaux_bi, ztauy_bi ! ice-OceanBottom stress at U-V points (landfast) + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztaux_base, ztauy_base ! ice-bottom stress at U-V points (landfast) ! - REAL(wp), DIMENSION(jpi,jpj) :: zmsk, zmsk00, zmsk15 - REAL(wp), DIMENSION(jpi,jpj) :: zmsk01x, zmsk01y ! dummy arrays - REAL(wp), DIMENSION(jpi,jpj) :: zmsk00x, zmsk00y ! mask for ice presence + REAL(wp), DIMENSION(jpi,jpj) :: zmsk + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zmsk01x, zmsk01y ! dummy arrays + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zmsk00x, zmsk00y ! mask for ice presence REAL(wp), PARAMETER :: zepsi = 1.0e-20_wp ! tolerance parameter REAL(wp), PARAMETER :: zmmin = 1._wp ! ice mass (kg/m2) below which ice velocity becomes very small REAL(wp), PARAMETER :: zamin = 0.001_wp ! ice concentration below which ice velocity becomes very small !! --- check convergence - REAL(wp), DIMENSION(jpi,jpj) :: zu_ice, zv_ice + REAL(wp), DIMENSION(A2D(0)) :: zmsk00, zmsk15 + REAL(wp), DIMENSION(A2D(0)) :: zu_ice, zv_ice !! --- diags REAL(wp) :: zsig1, zsig2, zsig12, zfac, z1_strength REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsig_I, zsig_II, zsig1_p, zsig2_p @@ -186,13 +187,15 @@ CONTAINS IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_rhg_evp: EVP sea-ice rheology' ! - ! for diagnostics and convergence tests DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice - zmsk (ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 1 if ice , 0 if no ice + zmsk (ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 1 if ice , 0 if no ice + END_2D + ! for diagnostics and convergence tests + DO_2D( 0, 0, 0, 0 ) + zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice END_2D IF( nn_rhg_chkcvg > 0 ) THEN - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less END_2D ENDIF @@ -265,6 +268,7 @@ CONTAINS DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) zm1 = ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) ) ! Ice/snow mass at U-V points +!!$ zm1 = ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) + rhow * (vt_ip(ji,jj) + vt_il(ji,jj)) ) ! clem: this should replace the above zmf (ji,jj) = zm1 * ff_t(ji,jj) ! Coriolis at T points (m*f) zdt_m(ji,jj) = zdtevp / MAX( zm1, zmmin ) ! dt/m at T points (for alpha and beta coefficients) END_2D @@ -277,8 +281,11 @@ CONTAINS ! Ice/snow mass at U-V points zm1 = ( rhos * vt_s(ji ,jj ) + rhoi * vt_i(ji ,jj ) ) +!!$ zm1 = ( rhos * vt_s(ji ,jj ) + rhoi * vt_i(ji ,jj ) + rhow * (vt_ip(ji ,jj ) + vt_il(ji ,jj )) ) ! clem: this should replace the above zm2 = ( rhos * vt_s(ji+1,jj ) + rhoi * vt_i(ji+1,jj ) ) +!!$ zm2 = ( rhos * vt_s(ji+1,jj ) + rhoi * vt_i(ji+1,jj ) + rhow * (vt_ip(ji+1,jj ) + vt_il(ji+1,jj )) ) ! clem: this should replace the above zm3 = ( rhos * vt_s(ji ,jj+1) + rhoi * vt_i(ji ,jj+1) ) +!!$ zm3 = ( rhos * vt_s(ji ,jj+1) + rhoi * vt_i(ji ,jj+1) + rhow * (vt_ip(ji ,jj+1) + vt_il(ji ,jj+1)) ) ! clem: this should replace the above zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) @@ -328,11 +335,12 @@ CONTAINS ! ice-bottom stress at V points zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) + END_2D + DO_2D( 0, 0, 0, 0 ) ! ice_bottom stress at T points zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) END_2D - CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1.0_wp ) ! ELSE !-- no landfast DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) @@ -352,7 +360,7 @@ CONTAINS ! ! convergence test IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1) END_2D @@ -722,7 +730,7 @@ CONTAINS ! ! ==================== ! END DO ! end loop over jter ! ! ! ==================== ! - IF( ln_aEVP ) CALL iom_put( 'beta_evp' , zbeta ) + IF( ln_aEVP ) CALL iom_put( 'beta_evp' , zbeta(A2D(0)) ) ! IF( ll_advups .AND. ln_str_H79 ) CALL lbc_lnk( 'icedyn_rhg_evp', strength, 'T', 1.0_wp ) ! @@ -776,8 +784,7 @@ CONTAINS END_2D - CALL lbc_lnk( 'icedyn_rhg_evp', pshear_i, 'T', 1._wp, pdivu_i, 'T', 1._wp, pdelta_i, 'T', 1._wp, zten_i, 'T', 1._wp, & - & zshear , 'T', 1._wp, zdelta , 'T', 1._wp, zs1 , 'T', 1._wp, zs2 , 'T', 1._wp, zs12, 'F', 1._wp ) + CALL lbc_lnk( 'icedyn_rhg_evp', zs1 , 'T', 1._wp, zs2 , 'T', 1._wp, zs12 , 'F', 1._wp ) ! --- Store the stress tensor for the next time step --- ! pstress1_i (:,:) = zs1 (:,:) @@ -787,34 +794,25 @@ CONTAINS ! 5) diagnostics !------------------------------------------------------------------------------! ! --- ice-ocean, ice-atm. & ice-oceanbottom(landfast) stresses --- ! - IF( iom_use('utau_oi') .OR. iom_use('vtau_oi') .OR. iom_use('utau_ai') .OR. iom_use('vtau_ai') .OR. & - & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN - ! - CALL lbc_lnk( 'icedyn_rhg_evp', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, & - & ztaux_ai, 'U', -1.0_wp, ztauy_ai, 'V', -1.0_wp, & - & ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) - ! - CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) - CALL iom_put( 'vtau_oi' , ztauy_oi * zmsk00 ) - CALL iom_put( 'utau_ai' , ztaux_ai * zmsk00 ) - CALL iom_put( 'vtau_ai' , ztauy_ai * zmsk00 ) - CALL iom_put( 'utau_bi' , ztaux_bi * zmsk00 ) - CALL iom_put( 'vtau_bi' , ztauy_bi * zmsk00 ) - ENDIF + IF( iom_use('utau_oi') ) CALL iom_put( 'utau_oi' , ztaux_oi(A2D(0)) * zmsk00 ) + IF( iom_use('vtau_oi') ) CALL iom_put( 'vtau_oi' , ztauy_oi(A2D(0)) * zmsk00 ) + IF( iom_use('utau_ai') ) CALL iom_put( 'utau_ai' , ztaux_ai(A2D(0)) * zmsk00 ) + IF( iom_use('vtau_ai') ) CALL iom_put( 'vtau_ai' , ztauy_ai(A2D(0)) * zmsk00 ) + IF( iom_use('utau_bi') ) CALL iom_put( 'utau_bi' , ztaux_bi(A2D(0)) * zmsk00 ) + IF( iom_use('vtau_bi') ) CALL iom_put( 'vtau_bi' , ztauy_bi(A2D(0)) * zmsk00 ) ! --- divergence, shear and strength --- ! - IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i * zmsk00 ) ! divergence - IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i * zmsk00 ) ! shear - IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength * zmsk00 ) ! strength - IF( iom_use('icedlt') ) CALL iom_put( 'icedlt' , zdelta * zmsk00 ) ! delta + IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i (A2D(0)) * zmsk00 ) ! divergence + IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i(A2D(0)) * zmsk00 ) ! shear + IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength(A2D(0)) * zmsk00 ) ! strength + IF( iom_use('icedlt') ) CALL iom_put( 'icedlt' , zdelta (A2D(0)) * zmsk00 ) ! delta ! --- Stress tensor invariants (SIMIP diags) --- ! IF( iom_use('normstr') .OR. iom_use('sheastr') ) THEN ! - ALLOCATE( zsig_I(jpi,jpj) , zsig_II(jpi,jpj) ) + ALLOCATE( zsig_I(A2D(0)) , zsig_II(A2D(0)) ) ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - + DO_2D( 0, 0, 0, 0 ) ! Ice stresses ! sigma1, sigma2, sigma12 are some recombination of the stresses (HD MWR002, Bouillon et al., OM2013) ! not to be confused with stress tensor components, stress invariants, or stress principal components @@ -829,8 +827,8 @@ CONTAINS END_2D ! - IF( iom_use('normstr') ) CALL iom_put( 'normstr', zsig_I (:,:) * zmsk00(:,:) ) ! Normal stress - IF( iom_use('sheastr') ) CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00(:,:) ) ! Maximum shear stress + IF( iom_use('normstr') ) CALL iom_put( 'normstr', zsig_I (:,:) * zmsk00 ) ! Normal stress + IF( iom_use('sheastr') ) CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00 ) ! Maximum shear stress DEALLOCATE ( zsig_I, zsig_II ) @@ -842,9 +840,9 @@ CONTAINS ! Recommendation 2 : for EVP, no need to use viscosities at last iteration (stress is properly iterated) IF( iom_use('sig1_pnorm') .OR. iom_use('sig2_pnorm') ) THEN ! - ALLOCATE( zsig1_p(jpi,jpj) , zsig2_p(jpi,jpj) , zsig_I(jpi,jpj) , zsig_II(jpi,jpj) ) + ALLOCATE( zsig1_p(A2D(0)) , zsig2_p(A2D(0)) , zsig_I(A2D(0)) , zsig_II(A2D(0)) ) ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! For EVP solvers, ice stresses at current iterates can be used ! following Lemieux & Dupont (2020) @@ -863,33 +861,26 @@ CONTAINS zsig2_p(ji,jj) = ( zsig_I(ji,jj) - zsig_II(ji,jj) ) * z1_strength END_2D ! - CALL iom_put( 'sig1_pnorm' , zsig1_p * zmsk00 ) - CALL iom_put( 'sig2_pnorm' , zsig2_p * zmsk00 ) + CALL iom_put( 'sig1_pnorm' , zsig1_p(:,:) * zmsk00 ) + CALL iom_put( 'sig2_pnorm' , zsig2_p(:,:) * zmsk00 ) DEALLOCATE( zsig1_p , zsig2_p , zsig_I, zsig_II ) ENDIF ! --- SIMIP --- ! - IF( iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. & - & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN - ! - CALL lbc_lnk( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & - & zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) - - CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x) - CALL iom_put( 'dssh_dy' , zspgV * zmsk00 ) ! Sea-surface tilt term in force balance (y) - CALL iom_put( 'corstrx' , zCorU * zmsk00 ) ! Coriolis force term in force balance (x) - CALL iom_put( 'corstry' , zCorV * zmsk00 ) ! Coriolis force term in force balance (y) - CALL iom_put( 'intstrx' , zfU * zmsk00 ) ! Internal force term in force balance (x) - CALL iom_put( 'intstry' , zfV * zmsk00 ) ! Internal force term in force balance (y) - ENDIF + IF( iom_use('dssh_dx') ) CALL iom_put( 'dssh_dx' , zspgU(A2D(0)) * zmsk00 ) ! Sea-surface tilt term in force balance (x) + IF( iom_use('dssh_dy') ) CALL iom_put( 'dssh_dy' , zspgV(A2D(0)) * zmsk00 ) ! Sea-surface tilt term in force balance (y) + IF( iom_use('corstrx') ) CALL iom_put( 'corstrx' , zCorU(A2D(0)) * zmsk00 ) ! Coriolis force term in force balance (x) + IF( iom_use('corstry') ) CALL iom_put( 'corstry' , zCorV(A2D(0)) * zmsk00 ) ! Coriolis force term in force balance (y) + IF( iom_use('intstrx') ) CALL iom_put( 'intstrx' , zfU (A2D(0)) * zmsk00 ) ! Internal force term in force balance (x) + IF( iom_use('intstry') ) CALL iom_put( 'intstry' , zfV (A2D(0)) * zmsk00 ) ! Internal force term in force balance (y) IF( iom_use('xmtrpice') .OR. iom_use('ymtrpice') .OR. & & iom_use('xmtrpsnw') .OR. iom_use('ymtrpsnw') .OR. iom_use('xatrp') .OR. iom_use('yatrp') ) THEN ! - ALLOCATE( zdiag_xmtrp_ice(jpi,jpj) , zdiag_ymtrp_ice(jpi,jpj) , & - & zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp(jpi,jpj) , zdiag_yatrp(jpi,jpj) ) + ALLOCATE( zdiag_xmtrp_ice(A2D(0)) , zdiag_ymtrp_ice(A2D(0)) , & + & zdiag_xmtrp_snw(A2D(0)) , zdiag_ymtrp_snw(A2D(0)) , zdiag_xatrp(A2D(0)) , zdiag_yatrp(A2D(0)) ) ! DO_2D( 0, 0, 0, 0 ) ! 2D ice mass, snow mass, area transport arrays (X, Y) @@ -907,10 +898,6 @@ CONTAINS END_2D - CALL lbc_lnk( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & - & zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & - & zdiag_xatrp , 'U', -1.0_wp, zdiag_yatrp , 'V', -1.0_wp ) - CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) CALL iom_put( 'ymtrpice' , zdiag_ymtrp_ice ) ! Y-component of sea-ice mass transport CALL iom_put( 'xmtrpsnw' , zdiag_xmtrp_snw ) ! X-component of snow mass transport (kg/s) @@ -927,11 +914,11 @@ CONTAINS IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN IF( iom_use('uice_cvg') ) THEN IF( ln_aEVP ) THEN ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) - CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * zbeta(:,:) * umask(:,:,1) , & - & ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * zmsk15(:,:) ) + CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(A2D(0)) - zu_ice(:,:) ) * zbeta(A2D(0)) * umask(A2D(0),1) , & + & ABS( v_ice(A2D(0)) - zv_ice(:,:) ) * zbeta(A2D(0)) * vmask(A2D(0),1) ) * zmsk15(:,:) ) ELSE ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) - CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * umask(:,:,1) , & - & ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * zmsk15(:,:) ) + CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(A2D(0)) - zu_ice(:,:) ) * umask(A2D(0),1) , & + & ABS( v_ice(A2D(0)) - zv_ice(:,:) ) * vmask(A2D(0),1) ) * zmsk15(:,:) ) ENDIF ENDIF ENDIF @@ -952,17 +939,18 @@ CONTAINS !! !! ** Note : for the first sub-iteration, uice_cvg is set to 0 (too large otherwise) !!---------------------------------------------------------------------- - INTEGER , INTENT(in) :: kt, kiter, kitermax ! ocean time-step index - REAL(wp), DIMENSION(:,:), INTENT(in) :: pu, pv, pub, pvb ! now and before velocities - REAL(wp), DIMENSION(:,:), INTENT(in) :: pmsk15 + INTEGER , INTENT(in) :: kt, kiter, kitermax ! ocean time-step index + REAL(wp), DIMENSION(:,:) , INTENT(in) :: pu, pv ! now velocities + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pub, pvb ! before velocities + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pmsk15 !! INTEGER :: it, idtime, istatus INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zresm ! local real CHARACTER(len=20) :: clname LOGICAL :: ll_maxcvg - REAL(wp), DIMENSION(jpi,jpj,2) :: zres - REAL(wp), DIMENSION(2) :: ztmp + REAL(wp), DIMENSION(A2D(0),2) :: zres + REAL(wp), DIMENSION(2) :: ztmp !!---------------------------------------------------------------------- ll_maxcvg = .FALSE. ! diff --git a/src/ICE/iceistate.F90 b/src/ICE/iceistate.F90 index 97c783148d78866bec1bf7f9aa9e240e91d1ed7a..283c6c34c7430fc6ea29a918314669178856db0f 100644 --- a/src/ICE/iceistate.F90 +++ b/src/ICE/iceistate.F90 @@ -37,6 +37,7 @@ MODULE iceistate USE lib_mpp ! MPP library USE lib_fortran ! fortran utilities (glob_sum + no signed zero) USE fldread ! read input fields + USE lbclnk ! ocean lateral boundary conditions (or mpp link) # if defined key_agrif USE agrif_oce @@ -113,11 +114,11 @@ CONTAINS INTEGER :: ji, jj, jk, jl ! dummy loop indices REAL(wp) :: ztmelts, zsshadj, area INTEGER , DIMENSION(4) :: itest - REAL(wp), DIMENSION(jpi,jpj) :: z2d REAL(wp), DIMENSION(jpi,jpj) :: zswitch ! ice indicator - REAL(wp), DIMENSION(jpi,jpj) :: zht_i_ini, zat_i_ini, ztm_s_ini !data from namelist or nc file - REAL(wp), DIMENSION(jpi,jpj) :: zt_su_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file - REAL(wp), DIMENSION(jpi,jpj) :: zapnd_ini, zhpnd_ini, zhlid_ini !data from namelist or nc file + REAL(wp), DIMENSION(A2D(0)) :: zmsk ! ice indicator + REAL(wp), DIMENSION(A2D(0)) :: zht_i_ini, zat_i_ini, ztm_s_ini !data from namelist or nc file + REAL(wp), DIMENSION(A2D(0)) :: zt_su_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file + REAL(wp), DIMENSION(A2D(0)) :: zapnd_ini, zhpnd_ini, zhlid_ini !data from namelist or nc file REAL(wp), DIMENSION(jpi,jpj,jpl) :: zti_3d , zts_3d !temporary arrays !! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d @@ -135,53 +136,59 @@ CONTAINS CALL eos_fzp( sss_m(:,:), t_bo(:,:) ) t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) ! - ! surface temperature and conductivity DO jl = 1, jpl - t_su (:,:,jl) = rt0 * tmask(:,:,1) ! temp at the surface - cnd_ice(:,:,jl) = 0._wp ! initialisation of the effective conductivity at the top of ice/snow (ln_cndflx=T) - END DO - ! - ! ice and snw temperatures - DO jl = 1, jpl - DO jk = 1, nlay_i - t_i(:,:,jk,jl) = rt0 * tmask(:,:,1) - END DO - DO jk = 1, nlay_s - t_s(:,:,jk,jl) = rt0 * tmask(:,:,1) - END DO - END DO - ! - ! specific temperatures for coupled runs - tn_ice (:,:,:) = t_i (:,:,1,:) - t1_ice (:,:,:) = t_i (:,:,1,:) - - ! heat contents - e_i (:,:,:,:) = 0._wp - e_s (:,:,:,:) = 0._wp - - ! general fields - a_i (:,:,:) = 0._wp - v_i (:,:,:) = 0._wp - v_s (:,:,:) = 0._wp - sv_i(:,:,:) = 0._wp - oa_i(:,:,:) = 0._wp - ! - h_i (:,:,:) = 0._wp - h_s (:,:,:) = 0._wp - s_i (:,:,:) = 0._wp - o_i (:,:,:) = 0._wp - ! - ! melt ponds - a_ip (:,:,:) = 0._wp - v_ip (:,:,:) = 0._wp - v_il (:,:,:) = 0._wp - a_ip_eff (:,:,:) = 0._wp - h_ip (:,:,:) = 0._wp - h_il (:,:,:) = 0._wp + ! == reduced arrays == ! + DO_2D( 0, 0, 0, 0 ) + ! + cnd_ice(ji,jj,jl) = 0._wp ! conductivity at the ice top + ! + tn_ice(ji,jj,jl) = t_i (ji,jj,1,jl) ! temp for coupled runs + t1_ice(ji,jj,jl) = t_i (ji,jj,1,jl) ! temp for coupled runs + ! + a_ip_eff(ji,jj,jl) = 0._wp ! melt pond effective fraction + END_2D + ! + ! == full arrays == ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + ! heat contents + DO jk = 1, nlay_i + e_i(ji,jj,jk,jl) = 0._wp + t_i(ji,jj,jk,jl) = rt0 * tmask(ji,jj,1) ! ice temp + ENDDO + DO jk = 1, nlay_s + e_s(ji,jj,jk,jl) = 0._wp + t_s(ji,jj,jk,jl) = rt0 * tmask(ji,jj,1) ! snw temp + ENDDO + ! + ! general fields + a_i (ji,jj,jl) = 0._wp + v_i (ji,jj,jl) = 0._wp + v_s (ji,jj,jl) = 0._wp + sv_i(ji,jj,jl) = 0._wp + oa_i(ji,jj,jl) = 0._wp + h_i (ji,jj,jl) = 0._wp + h_s (ji,jj,jl) = 0._wp + s_i (ji,jj,jl) = 0._wp + o_i (ji,jj,jl) = 0._wp + t_su(ji,jj,jl) = rt0 * tmask(ji,jj,1) + ! + ! melt ponds + a_ip(ji,jj,jl) = 0._wp + v_ip(ji,jj,jl) = 0._wp + v_il(ji,jj,jl) = 0._wp + h_ip(ji,jj,jl) = 0._wp + h_il(ji,jj,jl) = 0._wp + ! + END_2D + ! + ENDDO ! ! ice velocities - u_ice (:,:) = 0._wp - v_ice (:,:) = 0._wp + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + u_ice(ji,jj) = 0._wp + v_ice(ji,jj) = 0._wp + END_2D ! !------------------------------------------------------------------------ ! 2) overwrite some of the fields with namelist parameters or netcdf file @@ -194,30 +201,30 @@ CONTAINS ! !---------------! IF( nn_iceini_file == 1 )THEN ! Read a file ! ! !---------------! - WHERE( ff_t(:,:) >= 0._wp ) ; zswitch(:,:) = 1._wp - ELSEWHERE ; zswitch(:,:) = 0._wp + WHERE( ff_t(A2D(0)) >= 0._wp ) ; zmsk(:,:) = 1._wp + ELSEWHERE ; zmsk(:,:) = 0._wp END WHERE ! CALL fld_read( kt, 1, si ) ! input fields provided at the current time-step ! ! -- mandatory fields -- ! - zht_i_ini(:,:) = si(jp_hti)%fnow(:,:,1) * tmask(:,:,1) - zht_s_ini(:,:) = si(jp_hts)%fnow(:,:,1) * tmask(:,:,1) - zat_i_ini(:,:) = si(jp_ati)%fnow(:,:,1) * tmask(:,:,1) + zht_i_ini(:,:) = si(jp_hti)%fnow(:,:,1) * smask0(:,:) + zht_s_ini(:,:) = si(jp_hts)%fnow(:,:,1) * smask0(:,:) + zat_i_ini(:,:) = si(jp_ati)%fnow(:,:,1) * smask0(:,:) ! -- optional fields -- ! ! if fields do not exist then set them to the values present in the namelist (except for temperatures) ! ! ice salinity IF( TRIM(si(jp_smi)%clrootname) == 'NOT USED' ) & - & si(jp_smi)%fnow(:,:,1) = ( rn_smi_ini_n * zswitch + rn_smi_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + & si(jp_smi)%fnow(:,:,1) = ( rn_smi_ini_n * zmsk + rn_smi_ini_s * (1._wp - zmsk) ) * smask0(:,:) ! ! temperatures IF ( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. & & TRIM(si(jp_tms)%clrootname) == 'NOT USED' ) THEN - si(jp_tmi)%fnow(:,:,1) = ( rn_tmi_ini_n * zswitch + rn_tmi_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) - si(jp_tsu)%fnow(:,:,1) = ( rn_tsu_ini_n * zswitch + rn_tsu_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) - si(jp_tms)%fnow(:,:,1) = ( rn_tms_ini_n * zswitch + rn_tms_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + si(jp_tmi)%fnow(:,:,1) = ( rn_tmi_ini_n * zmsk + rn_tmi_ini_s * (1._wp - zmsk) ) * smask0(:,:) + si(jp_tsu)%fnow(:,:,1) = ( rn_tsu_ini_n * zmsk + rn_tsu_ini_s * (1._wp - zmsk) ) * smask0(:,:) + si(jp_tms)%fnow(:,:,1) = ( rn_tms_ini_n * zmsk + rn_tms_ini_s * (1._wp - zmsk) ) * smask0(:,:) ENDIF IF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) & ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 & si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tms)%fnow(:,:,1) + 271.15 ) @@ -234,67 +241,60 @@ CONTAINS ! ! pond concentration IF( TRIM(si(jp_apd)%clrootname) == 'NOT USED' ) & - & si(jp_apd)%fnow(:,:,1) = ( rn_apd_ini_n * zswitch + rn_apd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) & ! rn_apd = pond fraction => rn_apnd * a_i = pond conc. + & si(jp_apd)%fnow(:,:,1) = ( rn_apd_ini_n * zmsk + rn_apd_ini_s * (1._wp - zmsk) ) * smask0(:,:) & ! rn_apd = pond fraction => rn_apnd * a_i = pond conc. & * si(jp_ati)%fnow(:,:,1) ! ! pond depth IF( TRIM(si(jp_hpd)%clrootname) == 'NOT USED' ) & - & si(jp_hpd)%fnow(:,:,1) = ( rn_hpd_ini_n * zswitch + rn_hpd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + & si(jp_hpd)%fnow(:,:,1) = ( rn_hpd_ini_n * zmsk + rn_hpd_ini_s * (1._wp - zmsk) ) * smask0(:,:) ! ! pond lid depth IF( TRIM(si(jp_hld)%clrootname) == 'NOT USED' ) & - & si(jp_hld)%fnow(:,:,1) = ( rn_hld_ini_n * zswitch + rn_hld_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) + & si(jp_hld)%fnow(:,:,1) = ( rn_hld_ini_n * zmsk + rn_hld_ini_s * (1._wp - zmsk) ) * smask0(:,:) ! - zsm_i_ini(:,:) = si(jp_smi)%fnow(:,:,1) * tmask(:,:,1) - ztm_i_ini(:,:) = si(jp_tmi)%fnow(:,:,1) * tmask(:,:,1) - zt_su_ini(:,:) = si(jp_tsu)%fnow(:,:,1) * tmask(:,:,1) - ztm_s_ini(:,:) = si(jp_tms)%fnow(:,:,1) * tmask(:,:,1) - zapnd_ini(:,:) = si(jp_apd)%fnow(:,:,1) * tmask(:,:,1) - zhpnd_ini(:,:) = si(jp_hpd)%fnow(:,:,1) * tmask(:,:,1) - zhlid_ini(:,:) = si(jp_hld)%fnow(:,:,1) * tmask(:,:,1) + zsm_i_ini(:,:) = si(jp_smi)%fnow(:,:,1) * smask0(:,:) + ztm_i_ini(:,:) = si(jp_tmi)%fnow(:,:,1) * smask0(:,:) + zt_su_ini(:,:) = si(jp_tsu)%fnow(:,:,1) * smask0(:,:) + ztm_s_ini(:,:) = si(jp_tms)%fnow(:,:,1) * smask0(:,:) + zapnd_ini(:,:) = si(jp_apd)%fnow(:,:,1) * smask0(:,:) + zhpnd_ini(:,:) = si(jp_hpd)%fnow(:,:,1) * smask0(:,:) + zhlid_ini(:,:) = si(jp_hld)%fnow(:,:,1) * smask0(:,:) ! - ! change the switch for the following - WHERE( zat_i_ini(:,:) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1) - ELSEWHERE ; zswitch(:,:) = 0._wp - END WHERE - ! !---------------! ELSE ! Read namelist ! ! !---------------! ! no ice if (sst - Tfreez) >= thresold - WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst ) ; zswitch(:,:) = 0._wp - ELSEWHERE ; zswitch(:,:) = tmask(:,:,1) + WHERE( ( sst_m(A2D(0)) - (t_bo(A2D(0)) - rt0) ) * smask0(:,:) >= rn_thres_sst ) ; zmsk(:,:) = 0._wp + ELSEWHERE ; zmsk(:,:) = smask0(:,:) END WHERE ! ! assign initial thickness, concentration, snow depth and salinity to an hemisphere-dependent array - WHERE( ff_t(:,:) >= 0._wp ) - zht_i_ini(:,:) = rn_hti_ini_n * zswitch(:,:) - zht_s_ini(:,:) = rn_hts_ini_n * zswitch(:,:) - zat_i_ini(:,:) = rn_ati_ini_n * zswitch(:,:) - zsm_i_ini(:,:) = rn_smi_ini_n * zswitch(:,:) - ztm_i_ini(:,:) = rn_tmi_ini_n * zswitch(:,:) - zt_su_ini(:,:) = rn_tsu_ini_n * zswitch(:,:) - ztm_s_ini(:,:) = rn_tms_ini_n * zswitch(:,:) - zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. - zhpnd_ini(:,:) = rn_hpd_ini_n * zswitch(:,:) - zhlid_ini(:,:) = rn_hld_ini_n * zswitch(:,:) + WHERE( ff_t(A2D(0)) >= 0._wp ) + zht_i_ini(:,:) = rn_hti_ini_n * zmsk(:,:) + zht_s_ini(:,:) = rn_hts_ini_n * zmsk(:,:) + zat_i_ini(:,:) = rn_ati_ini_n * zmsk(:,:) + zsm_i_ini(:,:) = rn_smi_ini_n * zmsk(:,:) + ztm_i_ini(:,:) = rn_tmi_ini_n * zmsk(:,:) + zt_su_ini(:,:) = rn_tsu_ini_n * zmsk(:,:) + ztm_s_ini(:,:) = rn_tms_ini_n * zmsk(:,:) + zapnd_ini(:,:) = rn_apd_ini_n * zmsk(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. + zhpnd_ini(:,:) = rn_hpd_ini_n * zmsk(:,:) + zhlid_ini(:,:) = rn_hld_ini_n * zmsk(:,:) ELSEWHERE - zht_i_ini(:,:) = rn_hti_ini_s * zswitch(:,:) - zht_s_ini(:,:) = rn_hts_ini_s * zswitch(:,:) - zat_i_ini(:,:) = rn_ati_ini_s * zswitch(:,:) - zsm_i_ini(:,:) = rn_smi_ini_s * zswitch(:,:) - ztm_i_ini(:,:) = rn_tmi_ini_s * zswitch(:,:) - zt_su_ini(:,:) = rn_tsu_ini_s * zswitch(:,:) - ztm_s_ini(:,:) = rn_tms_ini_s * zswitch(:,:) - zapnd_ini(:,:) = rn_apd_ini_s * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. - zhpnd_ini(:,:) = rn_hpd_ini_s * zswitch(:,:) - zhlid_ini(:,:) = rn_hld_ini_s * zswitch(:,:) + zht_i_ini(:,:) = rn_hti_ini_s * zmsk(:,:) + zht_s_ini(:,:) = rn_hts_ini_s * zmsk(:,:) + zat_i_ini(:,:) = rn_ati_ini_s * zmsk(:,:) + zsm_i_ini(:,:) = rn_smi_ini_s * zmsk(:,:) + ztm_i_ini(:,:) = rn_tmi_ini_s * zmsk(:,:) + zt_su_ini(:,:) = rn_tsu_ini_s * zmsk(:,:) + ztm_s_ini(:,:) = rn_tms_ini_s * zmsk(:,:) + zapnd_ini(:,:) = rn_apd_ini_s * zmsk(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. + zhpnd_ini(:,:) = rn_hpd_ini_s * zmsk(:,:) + zhlid_ini(:,:) = rn_hld_ini_s * zmsk(:,:) END WHERE ! ENDIF - - ! make sure ponds = 0 if no ponds scheme IF ( .NOT.ln_pnd ) THEN zapnd_ini(:,:) = 0._wp @@ -311,7 +311,7 @@ CONTAINS !----------------! ! select ice covered grid points npti = 0 ; nptidx(:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF ( zht_i_ini(ji,jj) > 0._wp ) THEN npti = npti + 1 nptidx(npti) = (jj - 1) * jpi + ji @@ -363,6 +363,16 @@ CONTAINS DEALLOCATE( zhi_2d, zhs_2d, zai_2d , & & zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d ) + ! this call is needed because of the calculations above that are done only in the interior + CALL lbc_lnk( 'iceistate', a_i , 'T', 1._wp, h_i , 'T', 1._wp, h_s , 'T', 1._wp, & + & zti_3d, 'T', 1._wp, zts_3d, 'T', 1._wp, t_su, 'T', 1._wp, & + & s_i , 'T', 1._wp, a_ip , 'T', 1._wp, h_ip, 'T', 1._wp, h_il, 'T', 1._wp ) + + ! switch for the following + WHERE( SUM(a_i(:,:,:),dim=3) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1) + ELSEWHERE ; zswitch(:,:) = 0._wp + END WHERE + ! calculate extensive and intensive variables CALL ice_var_salprof ! for sz_i DO jl = 1, jpl @@ -398,15 +408,17 @@ CONTAINS ENDIF #endif ! Melt ponds - WHERE( a_i > epsi10 ) ; a_ip_eff(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) - ELSEWHERE ; a_ip_eff(:,:,:) = 0._wp + WHERE( a_i(A2D(0),:) > epsi10 ) ; a_ip_eff(:,:,:) = a_ip(A2D(0),:) / a_i(A2D(0),:) + ELSEWHERE ; a_ip_eff(:,:,:) = 0._wp END WHERE v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:) ! specific temperatures for coupled runs - tn_ice(:,:,:) = t_su(:,:,:) - t1_ice(:,:,:) = t_i (:,:,1,:) + DO_2D( 0, 0, 0, 0 ) + tn_ice(ji,jj,:) = t_su(ji,jj,:) + t1_ice(ji,jj,:) = t_i (ji,jj,1,:) + END_2D ! ! ice concentration should not exceed amax at_i(:,:) = SUM( a_i, dim=3 ) @@ -546,8 +558,8 @@ CONTAINS ENDIF ! DO ifpr = 1, jpfldi - ALLOCATE( si(ifpr)%fnow(jpi,jpj,1) ) - IF( slf_i(ifpr)%ln_tint ) ALLOCATE( si(ifpr)%fdta(jpi,jpj,1,2) ) + ALLOCATE( si(ifpr)%fnow(A2D(0),1) ) + IF( slf_i(ifpr)%ln_tint ) ALLOCATE( si(ifpr)%fdta(A2D(0),1,2) ) END DO ! ! fill si with slf_i and control print diff --git a/src/ICE/iceitd.F90 b/src/ICE/iceitd.F90 index f3e662748ae988a2ee5388c3085fb297b05b9efa..caa37df09026e7834a49f7739de63c92f38b2c81 100644 --- a/src/ICE/iceitd.F90 +++ b/src/ICE/iceitd.F90 @@ -29,6 +29,7 @@ MODULE iceitd USE lib_fortran ! fortran utilities (glob_sum + no signed zero) USE prtctl ! Print control USE timing ! Timing + USE lbclnk ! lateral boundary conditions (or mpp links) IMPLICIT NONE PRIVATE @@ -100,7 +101,7 @@ CONTAINS at_i(:,:) = SUM( a_i, dim=3 ) ! npti = 0 ; nptidx(:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF ( at_i(ji,jj) > epsi10 ) THEN npti = npti + 1 nptidx( npti ) = (jj - 1) * jpi + ji @@ -327,6 +328,9 @@ CONTAINS ! ENDIF ! + ! the following fields need to be updated in the halos (done afterwards): + ! a_i, v_i, v_s, sv_i, oa_i, h_i, a_ip, v_ip, v_il, t_su, e_i, e_s + ! IF( ln_icediachk ) CALL ice_cons_hsm(1, 'iceitd_rem', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) IF( ln_icediachk ) CALL ice_cons2D (1, 'iceitd_rem', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) IF( ln_timing ) CALL timing_stop ('iceitd_rem') @@ -626,7 +630,7 @@ CONTAINS DO jl = 1, jpl-1 ! identify thicknesses that are too big ! !--------------------------------------- npti = 0 ; nptidx(:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF( a_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN npti = npti + 1 nptidx( npti ) = (jj - 1) * jpi + ji @@ -662,7 +666,7 @@ CONTAINS DO jl = jpl-1, 1, -1 ! Identify thicknesses that are too small ! !----------------------------------------- npti = 0 ; nptidx(:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF( a_i(ji,jj,jl+1) > 0._wp .AND. v_i(ji,jj,jl+1) <= (a_i(ji,jj,jl+1) * hi_max(jl)) ) THEN npti = npti + 1 nptidx( npti ) = (jj - 1) * jpi + ji @@ -687,6 +691,14 @@ CONTAINS ! END DO ! + ! clem: the 2 lbc below could be avoided if calculations above were performed over the full domain + ! => decide if it is more efficient this way or not? + ! note: ice_itd_reb is called in icedyn + ! and in icethd (but once the arrays are already updated on the boundaries) + CALL lbc_lnk( 'iceitd_reb', a_i, 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp, oa_i, 'T', 1._wp, & + & h_i, 'T', 1._wp, a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp, t_su, 'T', 1._wp ) + CALL lbc_lnk( 'iceitd_reb', e_i, 'T', 1._wp, e_s , 'T', 1._wp ) + ! IF( ln_icediachk ) CALL ice_cons_hsm(1, 'iceitd_reb', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) IF( ln_icediachk ) CALL ice_cons2D (1, 'iceitd_reb', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) IF( ln_timing ) CALL timing_stop ('iceitd_reb') diff --git a/src/ICE/icesbc.F90 b/src/ICE/icesbc.F90 index 553e449977ecb918dceb80d381e687c85a001c72..03d5b83a6a9991211da476ecdb378f4e55ccf70c 100644 --- a/src/ICE/icesbc.F90 +++ b/src/ICE/icesbc.F90 @@ -58,7 +58,7 @@ CONTAINS REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: utau_ice, vtau_ice ! air-ice stress [N/m2] !! INTEGER :: ji, jj ! dummy loop index - REAL(wp), DIMENSION(jpi,jpj) :: zutau_ice, zvtau_ice + REAL(wp), DIMENSION(A2D(0)) :: zutau_ice, zvtau_ice !!------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('icesbc') @@ -70,25 +70,38 @@ CONTAINS ENDIF ! SELECT CASE( ksbc ) - CASE( jp_usr ) ; CALL usrdef_sbc_ice_tau( kt ) ! user defined formulation - CASE( jp_blk ) - CALL blk_ice_1( sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1), & - & theta_air_zt(:,:), q_air_zt(:,:), & ! #LB: known from "sbc_oce" module... - & sf(jp_slp )%fnow(:,:,1), u_ice, v_ice, tm_su , & ! inputs - & putaui = utau_ice, pvtaui = vtau_ice ) ! outputs - ! CASE( jp_abl ) utau_ice & vtau_ice are computed in ablmod - CASE( jp_purecpl ) ; CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) ! Coupled formulation + ! + CASE( jp_usr ) !--- User defined formulation + ! + CALL usrdef_sbc_ice_tau( kt ) + ! + CASE( jp_blk ) !--- Forced formulation + ! + CALL blk_ice_1( sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1), theta_air_zt(:,:), q_air_zt(:,:), & ! <<== in + & sf(jp_slp )%fnow(:,:,1), u_ice(A2D(0)), v_ice(A2D(0)), tm_su(:,:), & ! <<== in + & putaui = utau_ice(A2D(0)), pvtaui = vtau_ice(A2D(0)) ) ! ==>> out + ! + !CASE( jp_abl ) !--- ABL formulation (utau_ice & vtau_ice are computed in ablmod) + ! + CASE( jp_purecpl ) !--- Coupled formulation + ! + CALL sbc_cpl_ice_tau( utau_ice(A2D(0)) , vtau_ice(A2D(0)) ) + ! END SELECT ! - IF( ln_mixcpl) THEN ! Case of a mixed Bulk/Coupled formulation - CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) + IF( ln_mixcpl) THEN !--- Case of a mixed Bulk/Coupled formulation + ! + CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) + ! DO_2D( 0, 0, 0, 0 ) utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) END_2D - CALL lbc_lnk( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp ) + ! ENDIF ! + CALL lbc_lnk( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp ) + ! IF( ln_timing ) CALL timing_stop('icesbc') ! END SUBROUTINE ice_sbc_tau @@ -129,25 +142,49 @@ CONTAINS WRITE(numout,*)'~~~~~~~~~~~~~~~' ENDIF ! !== ice albedo ==! - CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) + CALL ice_alb( ln_pnd_alb, t_su(A2D(0),:), h_i(A2D(0),:), h_s(A2D(0),:), a_ip_eff(:,:,:), h_ip(A2D(0),:), cloud_fra(:,:), & ! <<== in + & alb_ice(:,:,:) ) ! ==>> out ! SELECT CASE( ksbc ) !== fluxes over sea ice ==! ! CASE( jp_usr ) !--- user defined formulation + ! CALL usrdef_sbc_ice_flx( kt, h_s, h_i ) + ! CASE( jp_blk, jp_abl ) !--- bulk formulation & ABL formulation - CALL blk_ice_2 ( t_su, h_s, h_i, alb_ice, & - & theta_air_zt(:,:), q_air_zt(:,:), & ! #LB: known from "sbc_oce" module... - & sf(jp_slp)%fnow(:,:,1), sf(jp_qlw)%fnow(:,:,1), & - & sf(jp_prec)%fnow(:,:,1), sf(jp_snow)%fnow(:,:,1) ) - IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( kt, picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i ) - IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist ) + ! + CALL blk_ice_2( t_su(A2D(0),:), h_s(A2D(0),:), h_i(A2D(0),:), & ! <<== in + & alb_ice(:,:,:), theta_air_zt(:,:), q_air_zt(:,:), & ! <<== in + & sf(jp_slp)%fnow(:,:,1), sf(jp_qlw)%fnow(:,:,1), & ! <<== in + & sf(jp_prec)%fnow(:,:,1), sf(jp_snow)%fnow(:,:,1) ) ! <<== in + ! + IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( kt, picefr=at_i_b(:,:), palbi=alb_ice(:,:,:), & + & psst=sst_m(A2D(0)), pist=t_su(A2D(0),:), & + & phs=h_s(A2D(0),:), phi=h_i(A2D(0),:) ) + CALL lbc_lnk( 'icesbc', t_su, 'T', 1.0_wp ) ! clem: t_su is needed for Met-Office only => necessary? + ! + IF( nn_flxdist /= -1 ) CALL ice_flx_dist( nn_flxdist, at_i(A2D(0)), a_i(A2D(0),:), t_su(A2D(0),:), alb_ice(:,:,:), & ! <<== in + & qns_ice(:,:,:), qsr_ice(:,:,:), dqns_ice(:,:,:), & ! ==>> inout + & evap_ice(:,:,:), devap_ice(:,:,:) ) ! ==>> inout + ! ! ! compute conduction flux and surface temperature (as in Jules surface module) - IF( ln_cndflx .AND. .NOT.ln_cndemulate ) & - & CALL blk_ice_qcn ( ln_virtual_itd, t_su, t_bo, h_s, h_i ) + IF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN + CALL blk_ice_qcn( ln_virtual_itd, t_bo(A2D(0)), h_s(A2D(0),:), h_i(A2D(0),:), & ! <<== in + & qcn_ice(:,:,:), qml_ice(:,:,:), & ! ==>> out + & qns_ice(:,:,:), t_su(A2D(0),:) ) ! ==>> inout + CALL lbc_lnk( 'icesbc', t_su, 'T', 1.0_wp ) ! clem: t_su is updated in ice_qcn => necessary? + ENDIF + ! CASE ( jp_purecpl ) !--- coupled formulation - CALL sbc_cpl_ice_flx( kt, picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i ) - IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist ) + ! + CALL sbc_cpl_ice_flx( kt, picefr=at_i_b(:,:), palbi=alb_ice(:,:,:), psst=sst_m(A2D(0)), & + & pist=t_su(A2D(0),:), phs=h_s(A2D(0),:), phi=h_i(A2D(0),:) ) + CALL lbc_lnk( 'icesbc', t_su, 'T', 1.0_wp ) ! clem: t_su is needed for Met-Office only => necessary? + ! + IF( nn_flxdist /= -1 ) CALL ice_flx_dist( nn_flxdist, at_i(A2D(0)), a_i(A2D(0),:), t_su(A2D(0),:), alb_ice(:,:,:), & ! <<== in + & qns_ice(:,:,:), qsr_ice(:,:,:), dqns_ice(:,:,:), & ! ==>> inout + & evap_ice(:,:,:), devap_ice(:,:,:) ) ! ==>> inout + ! END SELECT ! !== some fluxes at the ice-ocean interface and in the leads CALL ice_flx_other @@ -157,7 +194,8 @@ CONTAINS END SUBROUTINE ice_sbc_flx - SUBROUTINE ice_flx_dist( ptn_ice, palb_ice, pqns_ice, pqsr_ice, pdqn_ice, pevap_ice, pdevap_ice, k_flxdist ) + SUBROUTINE ice_flx_dist( k_flxdist, pat_i, pa_i, ptn_ice, palb_ice, & + & pqns_ice, pqsr_ice, pdqn_ice, pevap_ice, pdevap_ice ) !!------------------------------------------------------------------- !! *** ROUTINE ice_flx_dist *** !! @@ -173,18 +211,20 @@ CONTAINS !! using T-ice and albedo sensitivity !! = 2 Redistribute a single flux over categories !!------------------------------------------------------------------- - INTEGER , INTENT(in ) :: k_flxdist ! redistributor - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptn_ice ! ice surface temperature - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: palb_ice ! ice albedo - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pqns_ice ! non solar flux - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pqsr_ice ! net solar flux - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdqn_ice ! non solar flux sensitivity - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pevap_ice ! sublimation - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdevap_ice ! sublimation sensitivity + INTEGER , INTENT(in ) :: k_flxdist ! redistributor + REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: pat_i ! ice concentration + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: pa_i ! ice concentration + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: ptn_ice ! ice surface temperature + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: palb_ice ! ice albedo + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pqns_ice ! non solar flux + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pqsr_ice ! net solar flux + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pdqn_ice ! non solar flux sensitivity + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pevap_ice ! sublimation + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pdevap_ice ! sublimation sensitivity ! INTEGER :: jl ! dummy loop index ! - REAL(wp), DIMENSION(jpi,jpj) :: z1_at_i ! inverse of concentration + REAL(wp), DIMENSION(A2D(0)) :: z1_at_i ! inverse of concentration ! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_qsr_m ! Mean solar heat flux over all categories REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_qns_m ! Mean non solar heat flux over all categories @@ -195,7 +235,7 @@ CONTAINS REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztem_m ! Mean temperature over all categories !!---------------------------------------------------------------------- ! - WHERE ( at_i (:,:) > 0._wp ) ; z1_at_i(:,:) = 1._wp / at_i (:,:) + WHERE ( pat_i(:,:) > 0._wp ) ; z1_at_i(:,:) = 1._wp / pat_i(:,:) ELSEWHERE ; z1_at_i(:,:) = 0._wp END WHERE @@ -203,13 +243,13 @@ CONTAINS ! CASE( 0 , 1 ) ! - ALLOCATE( z_qns_m(jpi,jpj), z_qsr_m(jpi,jpj), z_dqn_m(jpi,jpj), z_evap_m(jpi,jpj), z_devap_m(jpi,jpj) ) + ALLOCATE( z_qns_m(A2D(0)), z_qsr_m(A2D(0)), z_dqn_m(A2D(0)), z_evap_m(A2D(0)), z_devap_m(A2D(0)) ) ! - z_qns_m (:,:) = SUM( a_i(:,:,:) * pqns_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) - z_qsr_m (:,:) = SUM( a_i(:,:,:) * pqsr_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) - z_dqn_m (:,:) = SUM( a_i(:,:,:) * pdqn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) - z_evap_m (:,:) = SUM( a_i(:,:,:) * pevap_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) - z_devap_m(:,:) = SUM( a_i(:,:,:) * pdevap_ice(:,:,:) , dim=3 ) * z1_at_i(:,:) + z_qns_m (:,:) = SUM( pa_i(:,:,:) * pqns_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + z_qsr_m (:,:) = SUM( pa_i(:,:,:) * pqsr_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + z_dqn_m (:,:) = SUM( pa_i(:,:,:) * pdqn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + z_evap_m (:,:) = SUM( pa_i(:,:,:) * pevap_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + z_devap_m(:,:) = SUM( pa_i(:,:,:) * pdevap_ice(:,:,:) , dim=3 ) * z1_at_i(:,:) DO jl = 1, jpl pqns_ice (:,:,jl) = z_qns_m (:,:) pqsr_ice (:,:,jl) = z_qsr_m (:,:) @@ -226,10 +266,10 @@ CONTAINS ! CASE( 1 , 2 ) ! - ALLOCATE( zalb_m(jpi,jpj), ztem_m(jpi,jpj) ) + ALLOCATE( zalb_m(A2D(0)), ztem_m(A2D(0)) ) ! - zalb_m(:,:) = SUM( a_i(:,:,:) * palb_ice(:,:,:) , dim=3 ) * z1_at_i(:,:) - ztem_m(:,:) = SUM( a_i(:,:,:) * ptn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) + zalb_m(:,:) = SUM( pa_i(:,:,:) * palb_ice(:,:,:) , dim=3 ) * z1_at_i(:,:) + ztem_m(:,:) = SUM( pa_i(:,:,:) * ptn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) DO jl = 1, jpl pqns_ice (:,:,jl) = pqns_ice (:,:,jl) + pdqn_ice (:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) pevap_ice(:,:,jl) = pevap_ice(:,:,jl) + pdevap_ice(:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) @@ -257,7 +297,7 @@ CONTAINS REAL(wp) :: zfric_u, zqld, zqfr, zqfr_neg, zqfr_pos, zu_io, zv_io, zu_iom1, zv_iom1 REAL(wp), PARAMETER :: zfric_umin = 0._wp ! lower bound for the friction velocity (cice value=5.e-04) REAL(wp), PARAMETER :: zch = 0.0057_wp ! heat transfer coefficient - REAL(wp), DIMENSION(jpi,jpj) :: zfric, zvel ! ice-ocean velocity (m/s) and frictional velocity (m2/s2) + REAL(wp), DIMENSION(A2D(0)) :: zfric, zvel ! ice-ocean velocity (m/s) and frictional velocity (m2/s2) !!----------------------------------------------------------------------- ! ! computation of friction velocity at T points @@ -268,14 +308,13 @@ CONTAINS zv_io = v_ice(ji ,jj ) - ssv_m(ji ,jj ) zv_iom1 = v_ice(ji ,jj-1) - ssv_m(ji ,jj-1) ! - zfric(ji,jj) = rn_cio * ( 0.5_wp * ( zu_io*zu_io + zu_iom1*zu_iom1 + zv_io*zv_io + zv_iom1*zv_iom1 ) ) * tmask(ji,jj,1) + zfric(ji,jj) = rn_cio * ( 0.5_wp * ( zu_io*zu_io + zu_iom1*zu_iom1 + zv_io*zv_io + zv_iom1*zv_iom1 ) ) * smask0(ji,jj) zvel (ji,jj) = 0.5_wp * SQRT( ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) + & & ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) END_2D - CALL lbc_lnk( 'icesbc', zfric, 'T', 1.0_wp, zvel, 'T', 1.0_wp ) ELSE ! if no ice dynamics => transfer directly the atmospheric stress to the ocean - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - zfric(ji,jj) = r1_rho0 * SQRT( utau(ji,jj)*utau(ji,jj) + vtau(ji,jj)*vtau(ji,jj) ) * tmask(ji,jj,1) + DO_2D( 0, 0, 0, 0 ) + zfric(ji,jj) = r1_rho0 * SQRT( utau(ji,jj)*utau(ji,jj) + vtau(ji,jj)*vtau(ji,jj) ) * smask0(ji,jj) zvel (ji,jj) = 0._wp END_2D ENDIF @@ -283,19 +322,19 @@ CONTAINS !--------------------------------------------------------------------! ! Partial computation of forcing for the thermodynamic sea ice model !--------------------------------------------------------------------! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! needed for qlead - rswitch = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice + DO_2D( 0, 0, 0, 0 ) ! needed for qlead + rswitch = smask0(ji,jj) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice ! ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! - zqld = tmask(ji,jj,1) * rDt_ice * & + zqld = smask0(ji,jj) * rDt_ice * & & ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) + & & ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) ! --- Energy needed to bring ocean surface layer until its freezing, zqfr is defined everywhere (J.m-2) --- ! ! (mostly<0 but >0 if supercooling) - zqfr = rho0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * tmask(ji,jj,1) ! both < 0 (t_bo < sst) and > 0 (t_bo > sst) - zqfr_neg = MIN( zqfr , 0._wp ) ! only < 0 - zqfr_pos = MAX( zqfr , 0._wp ) ! only > 0 + zqfr = rho0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * smask0(ji,jj) ! both < 0 (t_bo < sst) and > 0 (t_bo > sst) + zqfr_neg = MIN( zqfr , 0._wp ) ! only < 0 + zqfr_pos = MAX( zqfr , 0._wp ) ! only > 0 ! --- Sensible ocean-to-ice heat flux (W/m2) --- ! ! (mostly>0 but <0 if supercooling) diff --git a/src/ICE/icestp.F90 b/src/ICE/icestp.F90 index 070052dbbaf5a88d32e277c1df600355deeffadd..61d65ff74a34cdec309c98456cc490bfa3d16f9e 100644 --- a/src/ICE/icestp.F90 +++ b/src/ICE/icestp.F90 @@ -77,6 +77,7 @@ MODULE icestp USE lib_fortran ! fortran utilities (glob_sum + no signed zero) USE timing ! Timing USE prtctl ! Print control + USE lbclnk ! lateral boundary conditions (or mpp links) IMPLICIT NONE PRIVATE @@ -109,7 +110,7 @@ CONTAINS !! - save the outputs !! - save the outputs for restart when necessary !! - !! ** Action : - time evolution of the LIM sea-ice model + !! ** Action : - time evolution of the SI3 sea-ice model !! - update all sbc variables below sea-ice: !! utau, vtau, taum, wndm, qns , qsr, emp , sfx !!--------------------------------------------------------------------- @@ -117,7 +118,7 @@ CONTAINS INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices INTEGER, INTENT(in) :: ksbc ! flux formulation (user defined, bulk, or Pure Coupled) ! - INTEGER :: jl ! dummy loop index + INTEGER :: ji, jj, jl ! dummy loop index !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('icestp') @@ -128,9 +129,12 @@ CONTAINS ! kt_ice = kt ! -- Ice model time step ! - u_oce(:,:) = ssu_m(:,:) ! -- mean surface ocean current - v_oce(:,:) = ssv_m(:,:) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! -- mean surface ocean current + u_oce(ji,jj) = ssu_m(ji,jj) + v_oce(ji,jj) = ssv_m(ji,jj) + END_2D ! + ! clem: I think t_bo needs to be defined everywhere but check CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) ! -- freezing temperature [Kelvin] (set to rt0 over land) t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) ! @@ -152,6 +156,7 @@ CONTAINS ! utau_ice, vtau_ice = surface ice stress [N/m2] !------------------------------------------------! CALL ice_sbc_tau( kt, ksbc, utau_ice, vtau_ice ) + ! => clem: here utau_ice and vtau_ice are defined everywhere !-------------------------------------! ! --- ice dynamics and advection --- ! !-------------------------------------! @@ -161,6 +166,11 @@ CONTAINS IF( ln_icedyn .AND. .NOT.ln_c1d ) & & CALL ice_dyn( kt, Kmm ) ! -- Ice dynamics ! + ! ==> clem: here, all the global variables are correctly defined in the halos: + ! ato_i, a_i, v_i, v_s, sv_i, oa_i, a_ip, v_ip, v_il, e_i, e_s + ! as well as h_i and t_su for practical reasons + ! It may not be necessary. If it is not, then remove lbc_lnk in icedyn_rdgrft and iceitd_reb + CALL diag_trends( 1 ) ! record dyn trends ! ! !== lateral boundary conditions ==! @@ -170,7 +180,8 @@ CONTAINS CALL ice_var_glo2eqv ! h_i and h_s for ice albedo calculation CALL ice_var_agg(1) ! at_i for coupling CALL store_fields ! Store now ice values - ! + ! ==> clem: here, full arrays = vt_i, vt_s, vt_ip, vt_il, at_i, at_ip, ato_i + ! reduced arrays = st_i, et_i, et_s, tm_su !------------------------------------------------------! ! --- Thermodynamical coupling with the atmosphere --- ! !------------------------------------------------------! @@ -184,11 +195,15 @@ CONTAINS ! qemp_oce, qemp_ice, = sensible heat (associated with evap & precip) [W/m2] ! qprec_ice, qevap_ice !------------------------------------------------------! + ! ==> clem: From here on, we only need to work on the interior domain + ! though it necessitates a large lbc at the end of the time step CALL ice_sbc_flx( kt, ksbc ) !----------------------------! ! --- ice thermodynamics --- ! !----------------------------! IF( ln_icethd ) CALL ice_thd( kt ) ! -- Ice thermodynamics + ! + ! ==> clem: here, all the global variables are correctly defined in the halos ! CALL diag_trends( 2 ) ! record thermo trends CALL ice_var_glo2eqv ! necessary calls (at least for coupling) @@ -288,7 +303,7 @@ CONTAINS CALL ice_drift_init ! initialization for diags of conservation ! fr_i (:,:) = at_i(:,:) ! initialisation of sea-ice fraction - tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu + tn_ice(:,:,:) = t_su(A2D(0),:) ! initialisation of surface temp for coupled simu ! IF( ln_rstart ) THEN CALL iom_close( numrir ) ! close input ice restart file @@ -369,26 +384,33 @@ CONTAINS INTEGER :: ji, jj, jl ! dummy loop index !!---------------------------------------------------------------------- ! - a_i_b (:,:,:) = a_i (:,:,:) ! ice area - v_i_b (:,:,:) = v_i (:,:,:) ! ice volume - v_s_b (:,:,:) = v_s (:,:,:) ! snow volume - v_ip_b(:,:,:) = v_ip(:,:,:) ! pond volume - v_il_b(:,:,:) = v_il(:,:,:) ! pond lid volume - sv_i_b(:,:,:) = sv_i(:,:,:) ! salt content - e_s_b (:,:,:,:) = e_s (:,:,:,:) ! snow thermal energy - e_i_b (:,:,:,:) = e_i (:,:,:,:) ! ice thermal energy - WHERE( a_i_b(:,:,:) >= epsi20 ) - h_i_b(:,:,:) = v_i_b(:,:,:) / a_i_b(:,:,:) ! ice thickness - h_s_b(:,:,:) = v_s_b(:,:,:) / a_i_b(:,:,:) ! snw thickness - ELSEWHERE - h_i_b(:,:,:) = 0._wp - h_s_b(:,:,:) = 0._wp - END WHERE - ! - ! ice velocities & total concentration + DO jl = 1, jpl + DO_2D( 0, 0, 0, 0 ) + a_i_b (ji,jj,jl) = a_i (ji,jj,jl) ! ice area + v_i_b (ji,jj,jl) = v_i (ji,jj,jl) ! ice volume + v_s_b (ji,jj,jl) = v_s (ji,jj,jl) ! snow volume + v_ip_b(ji,jj,jl) = v_ip(ji,jj,jl) ! pond volume + v_il_b(ji,jj,jl) = v_il(ji,jj,jl) ! pond lid volume + sv_i_b(ji,jj,jl) = sv_i(ji,jj,jl) ! salt content + IF( a_i_b(ji,jj,jl) >= epsi20 ) THEN + h_i_b(ji,jj,jl) = v_i_b(ji,jj,jl) / a_i_b(ji,jj,jl) ! ice thickness + h_s_b(ji,jj,jl) = v_s_b(ji,jj,jl) / a_i_b(ji,jj,jl) ! snw thickness + ELSE + h_i_b(ji,jj,jl) = 0._wp + h_s_b(ji,jj,jl) = 0._wp + ENDIF + e_s_b (ji,jj,:,jl) = e_s (ji,jj,:,jl) ! snow thermal energy + e_i_b (ji,jj,:,jl) = e_i (ji,jj,:,jl) ! ice thermal energy + END_2D + ENDDO + ! total concentration at_i_b(:,:) = SUM( a_i_b(:,:,:), dim=3 ) - u_ice_b(:,:) = u_ice(:,:) - v_ice_b(:,:) = v_ice(:,:) + + ! ice velocity + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + u_ice_b(ji,jj) = u_ice(ji,jj) + v_ice_b(ji,jj) = v_ice(ji,jj) + END_2D ! END SUBROUTINE store_fields @@ -402,20 +424,23 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: ji, jj, jl ! dummy loop index !!---------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + sfx_res(ji,jj) = 0._wp ; wfx_res(ji,jj) = 0._wp ; hfx_res(ji,jj) = 0._wp + END_2D - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! needed for (at least) diag_adv_mass -> to be removed + DO_2D( 0, 0, 0, 0 ) sfx (ji,jj) = 0._wp ; sfx_bri(ji,jj) = 0._wp ; sfx_lam(ji,jj) = 0._wp sfx_sni(ji,jj) = 0._wp ; sfx_opw(ji,jj) = 0._wp sfx_bog(ji,jj) = 0._wp ; sfx_dyn(ji,jj) = 0._wp sfx_bom(ji,jj) = 0._wp ; sfx_sum(ji,jj) = 0._wp - sfx_res(ji,jj) = 0._wp ; sfx_sub(ji,jj) = 0._wp + sfx_sub(ji,jj) = 0._wp ! wfx_snw(ji,jj) = 0._wp ; wfx_ice(ji,jj) = 0._wp wfx_sni(ji,jj) = 0._wp ; wfx_opw(ji,jj) = 0._wp wfx_bog(ji,jj) = 0._wp ; wfx_dyn(ji,jj) = 0._wp wfx_bom(ji,jj) = 0._wp ; wfx_sum(ji,jj) = 0._wp - wfx_res(ji,jj) = 0._wp ; wfx_sub(ji,jj) = 0._wp + wfx_sub(ji,jj) = 0._wp wfx_spr(ji,jj) = 0._wp ; wfx_lam(ji,jj) = 0._wp wfx_snw_dyn(ji,jj) = 0._wp ; wfx_snw_sum(ji,jj) = 0._wp wfx_snw_sub(ji,jj) = 0._wp ; wfx_ice_sub(ji,jj) = 0._wp @@ -426,7 +451,7 @@ CONTAINS hfx_snw(ji,jj) = 0._wp ; hfx_opw(ji,jj) = 0._wp hfx_bog(ji,jj) = 0._wp ; hfx_dyn(ji,jj) = 0._wp hfx_bom(ji,jj) = 0._wp ; hfx_sum(ji,jj) = 0._wp - hfx_res(ji,jj) = 0._wp ; hfx_sub(ji,jj) = 0._wp + hfx_sub(ji,jj) = 0._wp hfx_spr(ji,jj) = 0._wp ; hfx_dif(ji,jj) = 0._wp hfx_err_dif(ji,jj) = 0._wp wfx_err_sub(ji,jj) = 0._wp @@ -451,7 +476,7 @@ CONTAINS END_2D DO jl = 1, jpl - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! SIMIP diagnostics t_si (ji,jj,jl) = rt0 ! temp at the ice-snow interface qcn_ice_bot(ji,jj,jl) = 0._wp @@ -477,22 +502,25 @@ CONTAINS !! and outputs !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: kn ! 1 = after dyn ; 2 = after thermo - !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jl ! dummy loop index + !!---------------------------------------------------------------------- ! ! --- trends of heat, salt, mass (used for conservation controls) IF( ln_icediachk .OR. iom_use('hfxdhc') ) THEN ! - diag_heat(:,:) = diag_heat(:,:) & - & - SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_Dt_ice & - & - SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_Dt_ice - diag_sice(:,:) = diag_sice(:,:) & - & + SUM( sv_i(:,:,:) - sv_i_b(:,:,:) , dim=3 ) * r1_Dt_ice * rhoi - diag_vice(:,:) = diag_vice(:,:) & - & + SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhoi - diag_vsnw(:,:) = diag_vsnw(:,:) & - & + SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhos - diag_vpnd(:,:) = diag_vpnd(:,:) & - & + SUM( v_ip + v_il - v_ip_b - v_il_b , dim=3 ) * r1_Dt_ice * rhow + DO_2D( 0, 0, 0, 0 ) + diag_heat(ji,jj) = diag_heat(ji,jj) & + & - SUM(SUM( e_i (ji,jj,1:nlay_i,:) - e_i_b (ji,jj,1:nlay_i,:), dim=2 ) ) * r1_Dt_ice & + & - SUM(SUM( e_s (ji,jj,1:nlay_s,:) - e_s_b (ji,jj,1:nlay_s,:), dim=2 ) ) * r1_Dt_ice + diag_sice(ji,jj) = diag_sice(ji,jj) & + & + SUM( sv_i(ji,jj,:) - sv_i_b(ji,jj,:) ) * r1_Dt_ice * rhoi + diag_vice(ji,jj) = diag_vice(ji,jj) & + & + SUM( v_i (ji,jj,:) - v_i_b (ji,jj,:) ) * r1_Dt_ice * rhoi + diag_vsnw(ji,jj) = diag_vsnw(ji,jj) & + & + SUM( v_s (ji,jj,:) - v_s_b (ji,jj,:) ) * r1_Dt_ice * rhos + diag_vpnd(ji,jj) = diag_vpnd(ji,jj) & + & + SUM( v_ip(ji,jj,:)+v_il(ji,jj,:) - v_ip_b(ji,jj,:)-v_il_b(ji,jj,:) ) * r1_Dt_ice * rhow + END_2D ! IF( kn == 2 ) CALL iom_put ( 'hfxdhc' , diag_heat ) ! output of heat trend ! @@ -501,10 +529,12 @@ CONTAINS ! --- trends of concentration (used for simip outputs) IF( iom_use('afxdyn') .OR. iom_use('afxthd') .OR. iom_use('afxtot') ) THEN ! - diag_aice(:,:) = diag_aice(:,:) + SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice + DO_2D( 0, 0, 0, 0 ) + diag_aice(ji,jj) = diag_aice(ji,jj) + SUM( a_i(ji,jj,:) - a_i_b(ji,jj,:) ) * r1_Dt_ice + END_2D ! IF( kn == 1 ) CALL iom_put( 'afxdyn' , diag_aice ) ! dyn trend - IF( kn == 2 ) CALL iom_put( 'afxthd' , SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice ) ! thermo trend + IF( kn == 2 ) CALL iom_put( 'afxthd' , SUM( a_i(A2D(0),:) - a_i_b(A2D(0),:), dim=3 ) * r1_Dt_ice ) ! thermo trend IF( kn == 2 ) CALL iom_put( 'afxtot' , diag_aice ) ! total trend ! ENDIF diff --git a/src/ICE/icetab.F90 b/src/ICE/icetab.F90 index 2b1b880f55bc92ee24f8c057ae6655fd4267ef43..02d3501ea1079cfa3d0c9b56aaf2ad8955b58a33 100644 --- a/src/ICE/icetab.F90 +++ b/src/ICE/icetab.F90 @@ -38,15 +38,24 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: ndim1d ! 1d size INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index - REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT(in ) :: tab2d ! input 2D field + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: tab2d ! input 2D field REAL(wp), DIMENSION(ndim1d,jpl) , INTENT(inout) :: tab1d ! output 1D field ! - INTEGER :: jl, jn, jid, jjd + INTEGER :: ipi, ipj, ji0, jj0, jl, jn, jid, jjd !!---------------------------------------------------------------------- + ipi = SIZE(tab2d,1) ! 1st dimension + ipj = SIZE(tab2d,2) ! 2nd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd + ji0 = 0 ; jj0 = 0 + ELSE ! reduced arrays then need to shift index by nn_hls + ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls + ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls) + ! DO jl = 1, jpl DO jn = 1, ndim1d - jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0 tab1d(jn,jl) = tab2d(jid,jjd,jl) END DO END DO @@ -59,14 +68,23 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: ndim1d ! 1d size INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: tab2d ! input 2D field + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: tab2d ! input 2D field REAL(wp), DIMENSION(ndim1d) , INTENT(inout) :: tab1d ! output 1D field ! - INTEGER :: jn , jid, jjd + INTEGER :: ipi, ipj, ji0, jj0, jn, jid, jjd !!---------------------------------------------------------------------- + ipi = SIZE(tab2d,1) ! 1st dimension + ipj = SIZE(tab2d,2) ! 2nd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd + ji0 = 0 ; jj0 = 0 + ELSE ! reduced arrays then need to shift index by nn_hls + ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls + ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls) + ! DO jn = 1, ndim1d - jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0 tab1d( jn) = tab2d( jid, jjd) END DO END SUBROUTINE tab_2d_1d @@ -79,14 +97,23 @@ CONTAINS INTEGER , INTENT(in ) :: ndim1d ! 1D size INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index REAL(wp), DIMENSION(ndim1d,jpl) , INTENT(in ) :: tab1d ! input 1D field - REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT(inout) :: tab2d ! output 2D field + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: tab2d ! output 2D field ! - INTEGER :: jl, jn, jid, jjd + INTEGER :: ipi, ipj, ji0, jj0, jl, jn, jid, jjd !!---------------------------------------------------------------------- + ipi = SIZE(tab2d,1) ! 1st dimension + ipj = SIZE(tab2d,2) ! 2nd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd + ji0 = 0 ; jj0 = 0 + ELSE ! reduced arrays then need to shift index by nn_hls + ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls + ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls) + ! DO jl = 1, jpl DO jn = 1, ndim1d - jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0 tab2d(jid,jjd,jl) = tab1d(jn,jl) END DO END DO @@ -100,13 +127,22 @@ CONTAINS INTEGER , INTENT(in ) :: ndim1d ! 1D size INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index REAL(wp), DIMENSION(ndim1d) , INTENT(in ) :: tab1d ! input 1D field - REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: tab2d ! output 2D field + REAL(wp), DIMENSION(:,:) , INTENT(inout) :: tab2d ! output 2D field ! - INTEGER :: jn , jid, jjd + INTEGER :: ipi, ipj, ji0, jj0, jn, jid, jjd !!---------------------------------------------------------------------- + ipi = SIZE(tab2d,1) ! 1st dimension + ipj = SIZE(tab2d,2) ! 2nd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd + ji0 = 0 ; jj0 = 0 + ELSE ! reduced arrays then need to shift index by nn_hls + ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls + ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls) + ! DO jn = 1, ndim1d - jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - jjd = ( tab_ind(jn) - 1 ) / jpi + 1 + jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0 + jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0 tab2d(jid, jjd) = tab1d( jn) END DO END SUBROUTINE tab_1d_2d diff --git a/src/ICE/icethd.F90 b/src/ICE/icethd.F90 index 3971c4415240950ed6423023821b958247370d3f..e831a062efa01f03350c0ca995613350d1e2c73e 100644 --- a/src/ICE/icethd.F90 +++ b/src/ICE/icethd.F90 @@ -98,7 +98,7 @@ CONTAINS ! convergence tests IF( ln_zdf_chkcvg ) THEN - ALLOCATE( ztice_cvgerr(jpi,jpj,jpl) , ztice_cvgstp(jpi,jpj,jpl) ) + ALLOCATE( ztice_cvgerr(A2D(0),jpl) , ztice_cvgstp(A2D(0),jpl) ) ztice_cvgerr = 0._wp ; ztice_cvgstp = 0._wp ENDIF ! @@ -111,7 +111,7 @@ CONTAINS ! select ice covered grid points npti = 0 ; nptidx(:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF ( a_i(ji,jj,jl) > epsi10 ) THEN npti = npti + 1 nptidx(npti) = (jj - 1) * jpi + ji @@ -158,6 +158,13 @@ CONTAINS IF( jpl > 1 ) CALL ice_itd_rem( kt ) ! --- Transport ice between thickness categories --- ! ! IF( ln_icedO ) CALL ice_thd_do ! --- Frazil ice growth in leads --- ! + ! + ! ! --- LBC for the halos --- ! + ! the 2 lbc below could be avoided if calculations above were performed over the full domain + ! but we think it is more efficient this way + CALL lbc_lnk( 'icethd', a_i , 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp, oa_i, 'T', 1._wp, & + & a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp, t_su, 'T', 1._wp ) + CALL lbc_lnk( 'icethd', e_i , 'T', 1._wp, e_s , 'T', 1._wp ) ! CALL ice_cor( kt , 2 ) ! --- Corrections --- ! ! diff --git a/src/ICE/icethd_do.F90 b/src/ICE/icethd_do.F90 index ace1000aa497d30ca52321d59e4a898dcff48e90..690af0e2129f7618ffca134804df7b8b1557ef9f 100644 --- a/src/ICE/icethd_do.F90 +++ b/src/ICE/icethd_do.F90 @@ -28,7 +28,6 @@ MODULE icethd_do USE in_out_manager ! I/O manager USE lib_mpp ! MPP library USE lib_fortran ! fortran utilities (glob_sum + no signed zero) - USE lbclnk ! lateral boundary conditions (or mpp links) IMPLICIT NONE PRIVATE @@ -105,7 +104,7 @@ CONTAINS IF( ln_icediachk ) CALL ice_cons_hsm( 0, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft ) IF( ln_icediachk ) CALL ice_cons2D ( 0, 'icethd_do', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft ) - at_i(:,:) = SUM( a_i, dim=3 ) + at_i(A2D(0)) = SUM( a_i(A2D(0),:), dim=3 ) !------------------------------------------------------------------------------! ! 1) Compute thickness, salinity, enthalpy, age, area and volume of new ice !------------------------------------------------------------------------------! @@ -113,7 +112,7 @@ CONTAINS ! Identify grid points where new ice forms npti = 0 ; nptidx(:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF ( qlead(ji,jj) < 0._wp ) THEN npti = npti + 1 nptidx( npti ) = (jj - 1) * jpi + ji @@ -325,6 +324,8 @@ CONTAINS ! ENDIF ! npti > 0 ! + ! the following fields need to be updated on the halos (done in icethd): a_i, v_i, sv_i, e_i + ! IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) IF( ln_icediachk ) CALL ice_cons2D (1, 'icethd_do', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! @@ -372,8 +373,8 @@ CONTAINS DO_2D( 0, 0, 0, 0 ) IF ( qlead(ji,jj) < 0._wp ) THEN ! cooling ! -- Wind stress -- ! - ztaux = utau_ice(ji,jj) * tmask(ji,jj,1) - ztauy = vtau_ice(ji,jj) * tmask(ji,jj,1) + ztaux = utau_ice(ji,jj) * smask0(ji,jj) + ztauy = vtau_ice(ji,jj) * smask0(ji,jj) ! Square root of wind stress ztenagm = SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) @@ -415,8 +416,6 @@ CONTAINS ! END_2D ! - CALL lbc_lnk( 'icethd_frazil', fraz_frac, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp ) - ENDIF END SUBROUTINE ice_thd_frazil diff --git a/src/ICE/icethd_pnd.F90 b/src/ICE/icethd_pnd.F90 index f0949d8f0a60d34ca08079f06367b099b10f079b..8f5b63df6fafe2d57bee60219d80aa32321082f9 100644 --- a/src/ICE/icethd_pnd.F90 +++ b/src/ICE/icethd_pnd.F90 @@ -84,7 +84,7 @@ CONTAINS INTEGER :: ji, jj, jl ! loop indices !!------------------------------------------------------------------- - ALLOCATE( diag_dvpn_mlt(jpi,jpj), diag_dvpn_lid(jpi,jpj), diag_dvpn_drn(jpi,jpj), diag_dvpn_rnf(jpi,jpj) ) + ALLOCATE( diag_dvpn_mlt(A2D(0)) , diag_dvpn_lid(A2D(0)) , diag_dvpn_drn(A2D(0)) , diag_dvpn_rnf(A2D(0)) ) ALLOCATE( diag_dvpn_mlt_1d(jpij), diag_dvpn_lid_1d(jpij), diag_dvpn_drn_1d(jpij), diag_dvpn_rnf_1d(jpij) ) ! diag_dvpn_mlt (:,:) = 0._wp ; diag_dvpn_drn (:,:) = 0._wp @@ -98,7 +98,7 @@ CONTAINS at_i(:,:) = SUM( a_i, dim=3 ) ! DO jl = 1, jpl - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF( v_i(ji,jj,jl) < epsi10 .OR. at_i(ji,jj) < epsi10 ) THEN wfx_pnd (ji,jj) = wfx_pnd(ji,jj) + ( v_ip(ji,jj,jl) + v_il(ji,jj,jl) ) * rhow * r1_Dt_ice a_ip (ji,jj,jl) = 0._wp @@ -115,7 +115,7 @@ CONTAINS ! Identify grid cells with ice !------------------------------ npti = 0 ; nptidx(:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF( at_i(ji,jj) >= epsi10 ) THEN npti = npti + 1 nptidx( npti ) = (jj - 1) * jpi + ji @@ -137,6 +137,8 @@ CONTAINS END SELECT ENDIF + ! the following fields need to be updated in the halos (done in icethd): a_ip, v_ip, v_il, h_ip, h_il + !------------------------------------ ! Diagnostics !------------------------------------ @@ -529,7 +531,7 @@ CONTAINS zv_pnd , & ! volume of meltwater contributing to ponds zv_mlt ! total amount of meltwater produced - REAL(wp), DIMENSION(jpi,jpj) :: zvolp_ini , & !! total melt pond water available before redistribution and drainage + REAL(wp), DIMENSION(A2D(0)) :: zvolp_ini , & !! total melt pond water available before redistribution and drainage zvolp , & !! total melt pond water volume zvolp_res !! remaining melt pond water available after drainage @@ -589,7 +591,7 @@ CONTAINS zvolp(:,:) = 0._wp DO jl = 1, jpl - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF ( a_i(ji,jj,jl) > epsi10 ) THEN @@ -637,7 +639,7 @@ CONTAINS IF( ln_pnd_lids ) THEN - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF ( at_i(ji,jj) > 0.01 .AND. hm_i(ji,jj) > rn_himin .AND. zvolp_ini(ji,jj) > zvp_min * at_i(ji,jj) ) THEN @@ -764,7 +766,7 @@ CONTAINS DO jl = 1, jpl - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! ! zap lids on small ponds ! IF ( a_i(ji,jj,jl) > epsi10 .AND. v_ip(ji,jj,jl) < epsi10 & @@ -826,7 +828,7 @@ CONTAINS !! !!------------------------------------------------------------------ - REAL (wp), DIMENSION(jpi,jpj), INTENT(INOUT) :: & + REAL (wp), DIMENSION(A2D(0)), INTENT(INOUT) :: & zvolp, & ! total available pond water zdvolp ! remaining meltwater after redistribution @@ -865,10 +867,10 @@ CONTAINS INTEGER :: ji, jj, jk, jl ! loop indices - a_ip(:,:,:) = 0._wp - h_ip(:,:,:) = 0._wp + a_ip(A2D(0),:) = 0._wp + h_ip(A2D(0),:) = 0._wp - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF ( at_i(ji,jj) > 0.01 .AND. hm_i(ji,jj) > rn_himin .AND. zvolp(ji,jj) > zvp_min * at_i(ji,jj) ) THEN diff --git a/src/ICE/iceupdate.F90 b/src/ICE/iceupdate.F90 index f6d047adf7c6abfbef6897311e8161cce3caa5f5..aac48c07cdb3eab6d8f77af8674db3215083f107 100644 --- a/src/ICE/iceupdate.F90 +++ b/src/ICE/iceupdate.F90 @@ -55,7 +55,7 @@ CONTAINS !!------------------------------------------------------------------- !! *** ROUTINE ice_update_alloc *** !!------------------------------------------------------------------- - ALLOCATE( utau_oce(jpi,jpj), vtau_oce(jpi,jpj), tmod_io(jpi,jpj), STAT=ice_update_alloc ) + ALLOCATE( utau_oce(A2D(0)), vtau_oce(A2D(0)), tmod_io(A2D(1)), STAT=ice_update_alloc ) ! CALL mpp_sum( 'iceupdate', ice_update_alloc ) IF( ice_update_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_update_alloc: failed to allocate arrays' ) @@ -104,22 +104,29 @@ CONTAINS ! Net heat flux on top of the ice-ocean (W.m-2) !---------------------------------------------- IF( ln_cndflx ) THEN ! ice-atm interface = conduction (and melting) fluxes - qt_atm_oi(:,:) = ( 1._wp - at_i_b(:,:) ) * ( qns_oce(:,:) + qsr_oce(:,:) ) + qemp_oce(:,:) + & - & SUM( a_i_b * ( qcn_ice + qml_ice + qtr_ice_top ), dim=3 ) + qemp_ice(:,:) + DO_2D( 0, 0, 0, 0 ) + qt_atm_oi(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * ( qns_oce(ji,jj) + qsr_oce(ji,jj) ) + qemp_oce(ji,jj) & + & + SUM( a_i_b(ji,jj,:) * ( qcn_ice(ji,jj,:) + qml_ice(ji,jj,:) + qtr_ice_top(ji,jj,:) ) ) & + & + qemp_ice(ji,jj) + END_2D ELSE ! ice-atm interface = solar and non-solar fluxes - qt_atm_oi(:,:) = qns_tot(:,:) + qsr_tot(:,:) + DO_2D( 0, 0, 0, 0 ) + qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj) + END_2D ENDIF ! --- case we bypass ice thermodynamics --- ! IF( .NOT. ln_icethd ) THEN ! we suppose ice is impermeable => ocean is isolated from atmosphere - qt_atm_oi (:,:) = ( 1._wp - at_i_b(:,:) ) * ( qns_oce(:,:) + qsr_oce(:,:) ) + qemp_oce(:,:) - qt_oce_ai (:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + qemp_oce(:,:) - emp_ice (:,:) = 0._wp - qemp_ice (:,:) = 0._wp - qevap_ice (:,:,:) = 0._wp + DO_2D( 0, 0, 0, 0 ) + qt_atm_oi (ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * ( qns_oce(ji,jj) + qsr_oce(ji,jj) ) + qemp_oce(ji,jj) + qt_oce_ai (ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) + emp_ice (ji,jj) = 0._wp + qemp_ice (ji,jj) = 0._wp + qevap_ice (ji,jj,:) = 0._wp + END_2D ENDIF - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! Solar heat flux reaching the ocean (max) = zqsr (W.m-2) !--------------------------------------------------- @@ -183,20 +190,22 @@ CONTAINS snwice_mass_b(ji,jj) = snwice_mass(ji,jj) ! save mass from the previous ice time step ! ! new mass per unit area snwice_mass (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) + rhow * (vt_ip(ji,jj) + vt_il(ji,jj)) ) - ! ! time evolution of snow+ice mass - snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_Dt_ice END_2D + CALL lbc_lnk( 'iceupdate', snwice_mass, 'T', 1.0_wp, snwice_mass_b, 'T', 1.0_wp ) ! needed for sshwzv and dynspg_ts (lbc on emp is done in sbcmod) + + ! time evolution of snow+ice mass + snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) * r1_Dt_ice ! Storing the transmitted variables !---------------------------------- fr_i (:,:) = at_i(:,:) ! Sea-ice fraction - tn_ice(:,:,:) = t_su(:,:,:) ! Ice surface temperature + tn_ice(:,:,:) = t_su(A2D(0),:) ! Ice surface temperature ! Snow/ice albedo (only if sent to coupler, useless in forced mode) !------------------------------------------------------------------ - CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) ! ice albedo - + CALL ice_alb( ln_pnd_alb, t_su(A2D(0),:), h_i(A2D(0),:), h_s(A2D(0),:), a_ip_eff(:,:,:), h_ip(A2D(0),:), cloud_fra(:,:), & ! <<== in + & alb_ice(:,:,:) ) ! ==>> out ! IF( lrst_ice ) THEN !* write snwice_mass fields in the restart file CALL update_rst( 'WRITE', kt ) @@ -216,8 +225,8 @@ CONTAINS IF( iom_use('sfxopw' ) ) CALL iom_put( 'sfxopw', sfx_opw * 1.e-03 ) ! salt flux from open water formation IF( iom_use('sfxdyn' ) ) CALL iom_put( 'sfxdyn', sfx_dyn * 1.e-03 ) ! salt flux from ridging rafting IF( iom_use('sfxbri' ) ) CALL iom_put( 'sfxbri', sfx_bri * 1.e-03 ) ! salt flux from brines - IF( iom_use('sfxres' ) ) CALL iom_put( 'sfxres', sfx_res * 1.e-03 ) ! salt flux from undiagnosed processes IF( iom_use('sfxsub' ) ) CALL iom_put( 'sfxsub', sfx_sub * 1.e-03 ) ! salt flux from sublimation + IF( iom_use('sfxres' ) ) CALL iom_put( 'sfxres', sfx_res(A2D(0)) * 1.e-03 ) ! salt flux from undiagnosed processes ! --- mass fluxes [kg/m2/s] --- ! CALL iom_put( 'emp_oce', emp_oce ) ! emp over ocean (taking into account the snow blown away from the ice) @@ -232,13 +241,13 @@ CONTAINS CALL iom_put( 'vfxsni' , wfx_sni ) ! mass flux from snow-ice formation CALL iom_put( 'vfxopw' , wfx_opw ) ! mass flux from growth in open water CALL iom_put( 'vfxdyn' , wfx_dyn ) ! mass flux from dynamics (ridging) - CALL iom_put( 'vfxres' , wfx_res ) ! mass flux from undiagnosed processes CALL iom_put( 'vfxpnd' , wfx_pnd ) ! mass flux from melt ponds CALL iom_put( 'vfxsub' , wfx_ice_sub ) ! mass flux from ice sublimation (ice-atm.) CALL iom_put( 'vfxsub_err', wfx_err_sub ) ! "excess" of sublimation sent to ocean + CALL iom_put( 'vfxres' , wfx_res(A2D(0)) ) ! mass flux from undiagnosed processes IF ( iom_use( 'vfxthin' ) ) THEN ! mass flux from ice growth in open water + thin ice (<20cm) => comparable to observations - ALLOCATE( z2d(jpi,jpj) ) + ALLOCATE( z2d(A2D(0)) ) WHERE( hm_i(:,:) < 0.2 .AND. hm_i(:,:) > 0. ) ; z2d = wfx_bog ELSEWHERE ; z2d = 0._wp END WHERE @@ -264,8 +273,8 @@ CONTAINS IF( iom_use('qtr_ice_top') ) CALL iom_put( 'qtr_ice_top', SUM( qtr_ice_top * a_i_b, dim=3 ) ) ! solar flux transmitted thru ice surface IF( iom_use('qt_oce' ) ) CALL iom_put( 'qt_oce' , ( qsr_oce + qns_oce ) * ( 1._wp - at_i_b ) + qemp_oce ) IF( iom_use('qt_ice' ) ) CALL iom_put( 'qt_ice' , SUM( ( qns_ice + qsr_ice ) * a_i_b, dim=3 ) + qemp_ice ) - IF( iom_use('qt_oce_ai' ) ) CALL iom_put( 'qt_oce_ai' , qt_oce_ai * tmask(:,:,1) ) ! total heat flux at the ocean surface: interface oce-(ice+atm) - IF( iom_use('qt_atm_oi' ) ) CALL iom_put( 'qt_atm_oi' , qt_atm_oi * tmask(:,:,1) ) ! total heat flux at the oce-ice surface: interface atm-(ice+oce) + IF( iom_use('qt_oce_ai' ) ) CALL iom_put( 'qt_oce_ai' , qt_oce_ai * smask0 ) ! total heat flux at the ocean surface: interface oce-(ice+atm) + IF( iom_use('qt_atm_oi' ) ) CALL iom_put( 'qt_atm_oi' , qt_atm_oi * smask0 ) ! total heat flux at the oce-ice surface: interface atm-(ice+oce) IF( iom_use('qemp_oce' ) ) CALL iom_put( 'qemp_oce' , qemp_oce ) ! Downward Heat Flux from E-P over ocean IF( iom_use('qemp_ice' ) ) CALL iom_put( 'qemp_ice' , qemp_ice ) ! Downward Heat Flux from E-P over ice @@ -282,9 +291,9 @@ CONTAINS ! heat fluxes associated with mass exchange (freeze/melt/precip...) CALL iom_put ('hfxthd' , hfx_thd ) ! CALL iom_put ('hfxdyn' , hfx_dyn ) ! - CALL iom_put ('hfxres' , hfx_res ) ! CALL iom_put ('hfxsub' , hfx_sub ) ! CALL iom_put ('hfxspr' , hfx_spr ) ! Heat flux from snow precip heat content + CALL iom_put ('hfxres' , hfx_res(A2D(0)) ) ! ! other heat fluxes IF( iom_use('hfxsensib' ) ) CALL iom_put( 'hfxsensib' , qsb_ice_bot * at_i_b ) ! Sensible oceanic heat flux @@ -350,27 +359,38 @@ CONTAINS zrhoco = rho0 * rn_cio ! IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN !== Ice time-step only ==! (i.e. surface module time-step) - DO_2D( 0, 0, 0, 0 ) !* update the modulus of stress at ocean surface (T-point) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* rhoco * |U_ice-U_oce| at T-point + ! ! 2*(U_ice-U_oce) at T-point + zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj) ! u_oce = ssu_m + zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1) ! v_oce = ssv_m + ! ! |U_ice-U_oce|^2 + zmodt = 0.25_wp * ( zu_t * zu_t + zv_t * zv_t ) + ! + tmod_io(ji,jj) = zrhoco * SQRT( zmodt ) + END_2D + IF( nn_hls == 1 ) CALL lbc_lnk( 'iceupdate', tmod_io, 'T', 1._wp ) + ! + DO_2D( 0, 0, 0, 0 ) !* save the air-ocean stresses at ice time-step ! ! 2*(U_ice-U_oce) at T-point zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj) ! u_oce = ssu_m zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1) ! v_oce = ssv_m - ! ! |U_ice-U_oce|^2 + ! ! |U_ice-U_oce|^2 zmodt = 0.25_wp * ( zu_t * zu_t + zv_t * zv_t ) ! ! update the ocean stress modulus taum(ji,jj) = ( 1._wp - at_i(ji,jj) ) * taum(ji,jj) + at_i(ji,jj) * zrhoco * zmodt - tmod_io(ji,jj) = zrhoco * SQRT( zmodt ) ! rhoco * |U_ice-U_oce| at T-point + ! + utau_oce(ji,jj) = utau(ji,jj) + vtau_oce(ji,jj) = vtau(ji,jj) END_2D - CALL lbc_lnk( 'iceupdate', taum, 'T', 1.0_wp, tmod_io, 'T', 1.0_wp ) - ! - utau_oce(:,:) = utau(:,:) !* save the air-ocean stresses at ice time-step - vtau_oce(:,:) = vtau(:,:) ! ENDIF ! ! !== every ocean time-step ==! IF ( ln_drgice_imp ) THEN ! Save drag with right sign to update top drag in the ocean implicit friction - rCdU_ice(:,:) = -r1_rho0 * tmod_io(:,:) * at_i(:,:) * tmask(:,:,1) + DO_2D( 1, 1, 1, 1 ) + rCdU_ice(ji,jj) = -r1_rho0 * tmod_io(ji,jj) * at_i(ji,jj) * tmask(ji,jj,1) + END_2D zflagi = 0._wp ELSE zflagi = 1._wp @@ -384,7 +404,6 @@ CONTAINS utau(ji,jj) = ( 1._wp - at_i(ji,jj) ) * utau_oce(ji,jj) + at_i(ji,jj) * zutau_ice vtau(ji,jj) = ( 1._wp - at_i(ji,jj) ) * vtau_oce(ji,jj) + at_i(ji,jj) * zvtau_ice END_2D - CALL lbc_lnk( 'iceupdate', utau, 'T', -1.0_wp, vtau, 'T', -1.0_wp ) ! lateral boundary condition ! IF( ln_timing ) CALL timing_stop('iceupdate') ! @@ -441,12 +460,12 @@ CONTAINS CALL iom_get( numrir, jpdom_auto, 'snwice_mass_b', snwice_mass_b ) ELSE ! start from rest IF(lwp) WRITE(numout,*) ' ==>> previous run without snow-ice mass output then set it' - snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) ) + snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) + rhow * (vt_ip(:,:) + vt_il(:,:)) ) snwice_mass_b(:,:) = snwice_mass(:,:) ENDIF ELSE !* Start from rest IF(lwp) WRITE(numout,*) ' ==>> start from rest: set the snow-ice mass' - snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) ) + snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) + rhow * (vt_ip(:,:) + vt_il(:,:)) ) snwice_mass_b(:,:) = snwice_mass(:,:) ENDIF ! diff --git a/src/ICE/icevar.F90 b/src/ICE/icevar.F90 index 535c5eb62a320b1c987727d2aacd4882abba6591..a51496309c363aae3446b253f5ff6c7d6ab08af8 100644 --- a/src/ICE/icevar.F90 +++ b/src/ICE/icevar.F90 @@ -117,70 +117,88 @@ CONTAINS REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z1_at_i, z1_vt_i, z1_vt_s !!------------------------------------------------------------------- ! - ! ! integrated values - vt_i(:,:) = SUM( v_i (:,:,:) , dim=3 ) - vt_s(:,:) = SUM( v_s (:,:,:) , dim=3 ) - st_i(:,:) = SUM( sv_i(:,:,:) , dim=3 ) - at_i(:,:) = SUM( a_i (:,:,:) , dim=3 ) - et_s(:,:) = SUM( SUM( e_s (:,:,:,:), dim=4 ), dim=3 ) - et_i(:,:) = SUM( SUM( e_i (:,:,:,:), dim=4 ), dim=3 ) + ! full arrays: vt_i, vt_s, at_i, vt_ip, vt_il, at_ip + ! reduced arrays: the rest ! - at_ip(:,:) = SUM( a_ip(:,:,:), dim=3 ) ! melt ponds - vt_ip(:,:) = SUM( v_ip(:,:,:), dim=3 ) - vt_il(:,:) = SUM( v_il(:,:,:), dim=3 ) + ! ! integrated values + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + vt_i(ji,jj) = SUM( v_i (ji,jj,:) ) + vt_s(ji,jj) = SUM( v_s (ji,jj,:) ) + at_i(ji,jj) = SUM( a_i (ji,jj,:) ) + ! + at_ip(ji,jj) = SUM( a_ip(ji,jj,:) ) ! melt ponds + vt_ip(ji,jj) = SUM( v_ip(ji,jj,:) ) + vt_il(ji,jj) = SUM( v_il(ji,jj,:) ) + END_2D + DO_2D( 0, 0, 0, 0 ) + st_i(ji,jj) = SUM( sv_i(ji,jj,:) ) + et_s(ji,jj) = SUM( SUM( e_s (ji,jj,:,:), dim=2 ) ) + et_i(ji,jj) = SUM( SUM( e_i (ji,jj,:,:), dim=2 ) ) + END_2D ! ato_i(:,:) = 1._wp - at_i(:,:) ! open water fraction ! !!GS: tm_su always needed by ABL over sea-ice - ALLOCATE( z1_at_i(jpi,jpj) ) - WHERE( at_i(:,:) > epsi20 ) ; z1_at_i(:,:) = 1._wp / at_i(:,:) - ELSEWHERE ; z1_at_i(:,:) = 0._wp + ALLOCATE( z1_at_i(A2D(0)) ) + WHERE( at_i(A2D(0)) > epsi20 ) ; z1_at_i(:,:) = 1._wp / at_i(A2D(0)) + ELSEWHERE ; z1_at_i(:,:) = 0._wp END WHERE - tm_su(:,:) = SUM( t_su(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:) - WHERE( at_i(:,:)<=epsi20 ) tm_su(:,:) = rt0 + DO_2D( 0, 0, 0, 0 ) + IF( at_i(ji,jj)<=epsi20 ) THEN + tm_su(ji,jj) = rt0 + ELSE + tm_su(ji,jj) = SUM( t_su(ji,jj,:) * a_i(ji,jj,:) ) * z1_at_i(ji,jj) + ENDIF + END_2D ! ! The following fields are calculated for diagnostics and outputs only ! ==> Do not use them for other purposes IF( kn > 1 ) THEN ! - ALLOCATE( z1_vt_i(jpi,jpj) , z1_vt_s(jpi,jpj) ) - WHERE( vt_i(:,:) > epsi20 ) ; z1_vt_i(:,:) = 1._wp / vt_i(:,:) - ELSEWHERE ; z1_vt_i(:,:) = 0._wp + ALLOCATE( z1_vt_i(A2D(0)) , z1_vt_s(A2D(0)) ) + WHERE( vt_i(A2D(0)) > epsi20 ) ; z1_vt_i(:,:) = 1._wp / vt_i(A2D(0)) + ELSEWHERE ; z1_vt_i(:,:) = 0._wp END WHERE - WHERE( vt_s(:,:) > epsi20 ) ; z1_vt_s(:,:) = 1._wp / vt_s(:,:) - ELSEWHERE ; z1_vt_s(:,:) = 0._wp + WHERE( vt_s(A2D(0)) > epsi20 ) ; z1_vt_s(:,:) = 1._wp / vt_s(A2D(0)) + ELSEWHERE ; z1_vt_s(:,:) = 0._wp END WHERE ! ! ! mean ice/snow thickness - hm_i(:,:) = vt_i(:,:) * z1_at_i(:,:) - hm_s(:,:) = vt_s(:,:) * z1_at_i(:,:) - ! - ! ! mean temperature (K), salinity and age - tm_si(:,:) = SUM( t_si(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:) - om_i (:,:) = SUM( oa_i(:,:,:) , dim=3 ) * z1_at_i(:,:) - sm_i (:,:) = st_i(:,:) * z1_vt_i(:,:) - ! - tm_i(:,:) = 0._wp - tm_s(:,:) = 0._wp - DO jl = 1, jpl - DO jk = 1, nlay_i - tm_i(:,:) = tm_i(:,:) + r1_nlay_i * t_i (:,:,jk,jl) * v_i(:,:,jl) * z1_vt_i(:,:) - END DO - DO jk = 1, nlay_s - tm_s(:,:) = tm_s(:,:) + r1_nlay_s * t_s (:,:,jk,jl) * v_s(:,:,jl) * z1_vt_s(:,:) + DO_2D( 0, 0, 0, 0 ) + hm_i(ji,jj) = vt_i(ji,jj) * z1_at_i(ji,jj) + hm_s(ji,jj) = vt_s(ji,jj) * z1_at_i(ji,jj) + ! + ! ! mean temperature (K), salinity and age + tm_si(ji,jj) = SUM( t_si(ji,jj,:) * a_i(ji,jj,:) ) * z1_at_i(ji,jj) + om_i (ji,jj) = SUM( oa_i(ji,jj,:) ) * z1_at_i(ji,jj) + sm_i (ji,jj) = st_i(ji,jj) * z1_vt_i(ji,jj) + ! + tm_i(ji,jj) = 0._wp + tm_s(ji,jj) = 0._wp + DO jl = 1, jpl + DO jk = 1, nlay_i + tm_i(ji,jj) = tm_i(ji,jj) + r1_nlay_i * t_i (ji,jj,jk,jl) * v_i(ji,jj,jl) * z1_vt_i(ji,jj) + END DO + DO jk = 1, nlay_s + tm_s(ji,jj) = tm_s(ji,jj) + r1_nlay_s * t_s (ji,jj,jk,jl) * v_s(ji,jj,jl) * z1_vt_s(ji,jj) + END DO END DO - END DO - ! + ! + END_2D ! ! put rt0 where there is no ice - WHERE( at_i(:,:)<=epsi20 ) + WHERE( at_i(A2D(0)) <= epsi20 ) tm_si(:,:) = rt0 tm_i (:,:) = rt0 tm_s (:,:) = rt0 END WHERE ! ! ! mean melt pond depth - WHERE( at_ip(:,:) > epsi20 ) ; hm_ip(:,:) = vt_ip(:,:) / at_ip(:,:) ; hm_il(:,:) = vt_il(:,:) / at_ip(:,:) - ELSEWHERE ; hm_ip(:,:) = 0._wp ; hm_il(:,:) = 0._wp + WHERE( at_ip(A2D(0)) > epsi20 ) + hm_ip(:,:) = vt_ip(A2D(0)) / at_ip(A2D(0)) + hm_il(:,:) = vt_il(A2D(0)) / at_ip(A2D(0)) + ELSEWHERE + hm_ip(:,:) = 0._wp + hm_il(:,:) = 0._wp END WHERE ! DEALLOCATE( z1_vt_i , z1_vt_s ) @@ -206,7 +224,8 @@ CONTAINS REAL(wp) :: zlay_i, zlay_s ! - - REAL(wp), PARAMETER :: zhl_max = 0.015_wp ! pond lid thickness above which the ponds disappear from the albedo calculation REAL(wp), PARAMETER :: zhl_min = 0.005_wp ! pond lid thickness below which the full pond area is used in the albedo calculation - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_a_i, z1_v_i, z1_a_ip, za_s_fra + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_a_i, z1_v_i, z1_a_ip + REAL(wp), DIMENSION(A2D(0),jpl) :: za_s_fra !!------------------------------------------------------------------- !!gm Question 2: It is possible to define existence of sea-ice in a common way between @@ -247,15 +266,15 @@ CONTAINS h_ip(:,:,:) = v_ip(:,:,:) * z1_a_ip(:,:,:) h_il(:,:,:) = v_il(:,:,:) * z1_a_ip(:,:,:) ! !--- melt pond effective area (used for albedo) - a_ip_frac(:,:,:) = a_ip(:,:,:) * z1_a_i(:,:,:) - WHERE ( h_il(:,:,:) <= zhl_min ) ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) ! lid is very thin. Expose all the pond - ELSEWHERE( h_il(:,:,:) >= zhl_max ) ; a_ip_eff(:,:,:) = 0._wp ! lid is very thick. Cover all the pond up with ice and snow - ELSEWHERE ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) * & ! lid is in between. Expose part of the pond - & ( zhl_max - h_il(:,:,:) ) / ( zhl_max - zhl_min ) + a_ip_frac(:,:,:) = a_ip(A2D(0),:) * z1_a_i(A2D(0),:) + WHERE ( h_il(A2D(0),:) <= zhl_min ) ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) ! lid is very thin. Expose all the pond + ELSEWHERE( h_il(A2D(0),:) >= zhl_max ) ; a_ip_eff(:,:,:) = 0._wp ! lid is very thick. Cover all the pond up with ice and snow + ELSEWHERE ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) * & ! lid is in between. Expose part of the pond + & ( zhl_max - h_il(A2D(0),:) ) / ( zhl_max - zhl_min ) END WHERE ! - CALL ice_var_snwfra( h_s, za_s_fra ) ! calculate ice fraction covered by snow - a_ip_eff = MIN( a_ip_eff, 1._wp - za_s_fra ) ! make sure (a_ip_eff + a_s_fra) <= 1 + CALL ice_var_snwfra( h_s(A2D(0),:), za_s_fra(:,:,:) ) ! calculate ice fraction covered by snow + a_ip_eff(:,:,:) = MIN( a_ip_eff(:,:,:), 1._wp - za_s_fra(:,:,:) ) ! make sure (a_ip_eff + a_s_fra) <= 1 ! ! !--- salinity (with a minimum value imposed everywhere) IF( nn_icesal == 2 ) THEN @@ -300,9 +319,9 @@ CONTAINS END DO ! ! integrated values - vt_i (:,:) = SUM( v_i , dim=3 ) - vt_s (:,:) = SUM( v_s , dim=3 ) - at_i (:,:) = SUM( a_i , dim=3 ) + vt_i (:,:) = SUM( v_i, dim=3 ) + vt_s (:,:) = SUM( v_s, dim=3 ) + at_i (:,:) = SUM( a_i, dim=3 ) ! END SUBROUTINE ice_var_glo2eqv @@ -538,7 +557,7 @@ CONTAINS sfx_res(ji,jj) = sfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl) * rhoi * r1_Dt_ice wfx_res(ji,jj) = wfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl) * rhoi * r1_Dt_ice wfx_res(ji,jj) = wfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl) * rhos * r1_Dt_ice - wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * ( v_ip(ji,jj,jl)+v_il(ji,jj,jl) ) * rhow * r1_Dt_ice + wfx_res(ji,jj) = wfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * ( v_ip(ji,jj,jl)+v_il(ji,jj,jl) ) * rhow * r1_Dt_ice ! a_i (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj) v_i (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj) @@ -640,11 +659,11 @@ CONTAINS psv_i (ji,jj,jl) = 0._wp ENDIF IF( pv_ip(ji,jj,jl) < 0._wp .OR. pv_il(ji,jj,jl) < 0._wp .OR. pa_ip(ji,jj,jl) <= 0._wp ) THEN - wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + pv_il(ji,jj,jl) * rhow * z1_dt + wfx_res(ji,jj) = wfx_res(ji,jj) + pv_il(ji,jj,jl) * rhow * z1_dt pv_il (ji,jj,jl) = 0._wp ENDIF IF( pv_ip(ji,jj,jl) < 0._wp .OR. pa_ip(ji,jj,jl) <= 0._wp ) THEN - wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + pv_ip(ji,jj,jl) * rhow * z1_dt + wfx_res(ji,jj) = wfx_res(ji,jj) + pv_ip(ji,jj,jl) * rhow * z1_dt pv_ip (ji,jj,jl) = 0._wp ENDIF END_2D @@ -713,15 +732,19 @@ CONTAINS !! instead of setting everything to zero as just below bv_i (:,:,:) = 0._wp DO jl = 1, jpl - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_i ) + DO_3D( 0, 0, 0, 0, 1, nlay_i ) IF( t_i(ji,jj,jk,jl) < rt0 - epsi10 ) THEN bv_i(ji,jj,jl) = bv_i(ji,jj,jl) - rTmlt * sz_i(ji,jj,jk,jl) * r1_nlay_i / ( t_i(ji,jj,jk,jl) - rt0 ) ENDIF END_3D END DO - WHERE( vt_i(:,:) > epsi20 ) ; bvm_i(:,:) = SUM( bv_i(:,:,:) * v_i(:,:,:) , dim=3 ) / vt_i(:,:) - ELSEWHERE ; bvm_i(:,:) = 0._wp - END WHERE + DO_2D( 0, 0, 0, 0 ) + IF( vt_i(ji,jj) > epsi20 ) THEN + bvm_i(ji,jj) = SUM( bv_i(ji,jj,:) * v_i(ji,jj,:) ) / vt_i(ji,jj) + ELSE + bvm_i(ji,jj) = 0._wp + ENDIF + END_2D ! END SUBROUTINE ice_var_bv @@ -1286,8 +1309,8 @@ CONTAINS !! !!------------------------------------------------------------------- SUBROUTINE ice_var_snwfra_3d( ph_s, pa_s_fra ) - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ph_s ! snow thickness - REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: ph_s ! snow thickness + REAL(wp), DIMENSION(A2D(0),jpl), INTENT( out) :: pa_s_fra ! ice fraction covered by snow IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp ELSEWHERE ; pa_s_fra = 0._wp @@ -1344,8 +1367,8 @@ CONTAINS !!-------------------------------------------------------------------------- !!gm I think it can be usefull to set this as a FUNCTION, not a SUBROUTINE.... SUBROUTINE ice_var_snwblow_2d( pin, pout ) - REAL(wp), DIMENSION(:,:), INTENT(in ) :: pin ! previous fraction lead ( 1. - a_i_b ) - REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout + REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pin ! previous fraction lead ( 1. - a_i_b ) + REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pout pout = ( 1._wp - ( pin )**rn_snwblow ) END SUBROUTINE ice_var_snwblow_2d diff --git a/src/ICE/icewri.F90 b/src/ICE/icewri.F90 index 078e3b007baf4ff4ea136f0426dccfed9adbf189..6da84cd4ee44987f61851c4b676ee76bba24f62c 100644 --- a/src/ICE/icewri.F90 +++ b/src/ICE/icewri.F90 @@ -26,7 +26,6 @@ MODULE icewri USE iom ! I/O manager library USE lib_mpp ! MPP library USE lib_fortran ! fortran utilities (glob_sum + no signed zero) - USE lbclnk ! lateral boundary conditions (or mpp links) USE timing ! Timing IMPLICIT NONE @@ -53,10 +52,10 @@ CONTAINS INTEGER :: ji, jj, jk, jl ! dummy loop indices REAL(wp) :: z2da, z2db, zrho1, zrho2 REAL(wp) :: zmiss_val ! missing value retrieved from xios - REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace - REAL(wp), DIMENSION(jpi,jpj) :: zmsk00, zmsk05, zmsk15, zmsksn ! O%, 5% and 15% concentration mask and snow mask - REAL(wp), DIMENSION(jpi,jpj,jpl) :: zmsk00l, zmsksnl ! cat masks - REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zfast, zalb, zmskalb ! 2D workspace + REAL(wp), DIMENSION(A2D(0)) :: z2d ! 2D workspace + REAL(wp), DIMENSION(A2D(0)) :: zmsk00, zmsk05, zmsk15, zmsksn ! O%, 5% and 15% concentration mask and snow mask + REAL(wp), DIMENSION(A2D(0),jpl) :: zmsk00l, zmsksnl ! cat masks + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zfast, zalb, zmskalb ! 2D workspace ! ! Global ice diagnostics (SIMIP) REAL(wp) :: zdiag_area_nh, zdiag_extt_nh, zdiag_volu_nh ! area, extent, volume @@ -72,14 +71,14 @@ CONTAINS CALL ice_var_bv ! tresholds for outputs - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice zmsk05(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.05_wp ) ) ! 1 if 5% ice , 0 if less zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less zmsksn(ji,jj) = MAX( 0._wp , SIGN( 1._wp , vt_s(ji,jj) - epsi06 ) ) ! 1 if snow , 0 if no snow END_2D DO jl = 1, jpl - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zmsk00l(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) zmsksnl(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi06 ) ) END_2D @@ -96,102 +95,111 @@ CONTAINS CALL iom_put( 'icepres' , zmsk00 ) ! Ice presence (1 or 0) ! ! general fields - IF( iom_use('icemass' ) ) CALL iom_put( 'icemass', vt_i * rhoi * zmsk00 ) ! Ice mass per cell area - IF( iom_use('snwmass' ) ) CALL iom_put( 'snwmass', vt_s * rhos * zmsksn ) ! Snow mass per cell area - IF( iom_use('iceconc' ) ) CALL iom_put( 'iceconc', at_i * zmsk00 ) ! ice concentration - IF( iom_use('icevolu' ) ) CALL iom_put( 'icevolu', vt_i * zmsk00 ) ! ice volume = mean ice thickness over the cell - IF( iom_use('icethic' ) ) CALL iom_put( 'icethic', hm_i * zmsk00 ) ! ice thickness - IF( iom_use('snwthic' ) ) CALL iom_put( 'snwthic', hm_s * zmsk00 ) ! snw thickness - IF( iom_use('icebrv' ) ) CALL iom_put( 'icebrv' , bvm_i* 100. * zmsk00 ) ! brine volume - IF( iom_use('iceage' ) ) CALL iom_put( 'iceage' , om_i / rday * zmsk15 + zmiss_val * ( 1._wp - zmsk15 ) ) ! ice age - IF( iom_use('icehnew' ) ) CALL iom_put( 'icehnew', ht_i_new ) ! new ice thickness formed in the leads - IF( iom_use('snwvolu' ) ) CALL iom_put( 'snwvolu', vt_s * zmsksn ) ! snow volume - IF( iom_use('icefrb' ) ) THEN ! Ice freeboard - z2d(:,:) = ( zrho1 * hm_i(:,:) - zrho2 * hm_s(:,:) ) + IF( iom_use('icemass' ) ) CALL iom_put( 'icemass', vt_i(A2D(0)) * rhoi * zmsk00 ) ! Ice mass per cell area + IF( iom_use('snwmass' ) ) CALL iom_put( 'snwmass', vt_s(A2D(0)) * rhos * zmsksn ) ! Snow mass per cell area + IF( iom_use('iceconc' ) ) CALL iom_put( 'iceconc', at_i(A2D(0)) * zmsk00 ) ! ice concentration + IF( iom_use('icevolu' ) ) CALL iom_put( 'icevolu', vt_i(A2D(0)) * zmsk00 ) ! ice volume = mean ice thickness over the cell + IF( iom_use('icethic' ) ) CALL iom_put( 'icethic', hm_i(:,:) * zmsk00 ) ! ice thickness + IF( iom_use('snwthic' ) ) CALL iom_put( 'snwthic', hm_s(:,:) * zmsk00 ) ! snw thickness + IF( iom_use('icebrv' ) ) CALL iom_put( 'icebrv' , bvm_i(:,:)* 100. * zmsk00 ) ! brine volume + IF( iom_use('iceage' ) ) CALL iom_put( 'iceage' , om_i(:,:) / rday * zmsk15 + zmiss_val * ( 1._wp - zmsk15 ) ) ! ice age + IF( iom_use('icehnew' ) ) CALL iom_put( 'icehnew', ht_i_new(:,:) ) ! new ice thickness formed in the leads + IF( iom_use('snwvolu' ) ) CALL iom_put( 'snwvolu', vt_s(A2D(0)) * zmsksn ) ! snow volume + IF( iom_use('icefrb' ) ) THEN ! Ice freeboard + z2d(:,:) = zrho1 * hm_i(:,:) - zrho2 * hm_s(:,:) WHERE( z2d < 0._wp ) z2d = 0._wp - CALL iom_put( 'icefrb' , z2d * zmsk00 ) + CALL iom_put( 'icefrb' , z2d * zmsk00 ) ENDIF ! melt ponds - IF( iom_use('iceapnd' ) ) CALL iom_put( 'iceapnd', at_ip * zmsk00 ) ! melt pond total fraction - IF( iom_use('icehpnd' ) ) CALL iom_put( 'icehpnd', hm_ip * zmsk00 ) ! melt pond depth - IF( iom_use('icevpnd' ) ) CALL iom_put( 'icevpnd', vt_ip * zmsk00 ) ! melt pond total volume per unit area - IF( iom_use('icehlid' ) ) CALL iom_put( 'icehlid', hm_il * zmsk00 ) ! melt pond lid depth - IF( iom_use('icevlid' ) ) CALL iom_put( 'icevlid', vt_il * zmsk00 ) ! melt pond lid total volume per unit area + IF( iom_use('iceapnd' ) ) CALL iom_put( 'iceapnd', at_ip(A2D(0)) * zmsk00 ) ! melt pond total fraction + IF( iom_use('icehpnd' ) ) CALL iom_put( 'icehpnd', hm_ip(:,:) * zmsk00 ) ! melt pond depth + IF( iom_use('icevpnd' ) ) CALL iom_put( 'icevpnd', vt_ip(A2D(0)) * zmsk00 ) ! melt pond total volume per unit area + IF( iom_use('icehlid' ) ) CALL iom_put( 'icehlid', hm_il(:,:) * zmsk00 ) ! melt pond lid depth + IF( iom_use('icevlid' ) ) CALL iom_put( 'icevlid', vt_il(A2D(0)) * zmsk00 ) ! melt pond lid total volume per unit area ! salt - IF( iom_use('icesalt' ) ) CALL iom_put( 'icesalt', sm_i * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! mean ice salinity - IF( iom_use('icesalm' ) ) CALL iom_put( 'icesalm', st_i * rhoi * 1.0e-3 * zmsk00 ) ! Mass of salt in sea ice per cell area + IF( iom_use('icesalt' ) ) CALL iom_put( 'icesalt', sm_i(:,:) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! mean ice salinity + IF( iom_use('icesalm' ) ) CALL iom_put( 'icesalm', st_i(:,:) * rhoi * 1.0e-3 * zmsk00 ) ! Mass of salt in sea ice per cell area ! heat - IF( iom_use('icetemp' ) ) CALL iom_put( 'icetemp', ( tm_i - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! ice mean temperature - IF( iom_use('snwtemp' ) ) CALL iom_put( 'snwtemp', ( tm_s - rt0 ) * zmsksn + zmiss_val * ( 1._wp - zmsksn ) ) ! snw mean temperature - IF( iom_use('icettop' ) ) CALL iom_put( 'icettop', ( tm_su - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice surface - IF( iom_use('icetbot' ) ) CALL iom_put( 'icetbot', ( t_bo - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice bottom - IF( iom_use('icetsni' ) ) CALL iom_put( 'icetsni', ( tm_si - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the snow-ice interface - IF( iom_use('icehc' ) ) CALL iom_put( 'icehc' , -et_i * zmsk00 ) ! ice heat content - IF( iom_use('snwhc' ) ) CALL iom_put( 'snwhc' , -et_s * zmsksn ) ! snow heat content + IF( iom_use('icetemp' ) ) CALL iom_put( 'icetemp', ( tm_i(:,:) - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! ice mean temperature + IF( iom_use('snwtemp' ) ) CALL iom_put( 'snwtemp', ( tm_s(:,:) - rt0 ) * zmsksn + zmiss_val * ( 1._wp - zmsksn ) ) ! snw mean temperature + IF( iom_use('icettop' ) ) CALL iom_put( 'icettop', ( tm_su(:,:) - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice surface + IF( iom_use('icetbot' ) ) CALL iom_put( 'icetbot', ( t_bo(A2D(0)) - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice bottom + IF( iom_use('icetsni' ) ) CALL iom_put( 'icetsni', ( tm_si(:,:) - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the snow-ice interface + IF( iom_use('icehc' ) ) CALL iom_put( 'icehc' , -et_i(:,:) * zmsk00 ) ! ice heat content + IF( iom_use('snwhc' ) ) CALL iom_put( 'snwhc' , -et_s(:,:) * zmsksn ) ! snow heat content ! momentum - IF( iom_use('uice' ) ) CALL iom_put( 'uice' , u_ice ) ! ice velocity u - IF( iom_use('vice' ) ) CALL iom_put( 'vice' , v_ice ) ! ice velocity v + IF( iom_use('uice' ) ) CALL iom_put( 'uice' , u_ice(A2D(0)) ) ! ice velocity u + IF( iom_use('vice' ) ) CALL iom_put( 'vice' , v_ice(A2D(0)) ) ! ice velocity v ! - IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN ! module of ice velocity & fast ice - ALLOCATE( zfast(jpi,jpj) ) + IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN ! module of ice velocity & fast ice + ALLOCATE( zfast(A2D(0)) ) DO_2D( 0, 0, 0, 0 ) z2da = u_ice(ji,jj) + u_ice(ji-1,jj) z2db = v_ice(ji,jj) + v_ice(ji,jj-1) z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) END_2D - CALL lbc_lnk( 'icewri', z2d, 'T', 1.0_wp ) CALL iom_put( 'icevel', z2d ) - WHERE( z2d(:,:) < 5.e-04_wp .AND. zmsk15(:,:) == 1._wp ) ; zfast(:,:) = 1._wp ! record presence of fast ice + WHERE( z2d(:,:) < 5.e-04_wp .AND. zmsk15(:,:) == 1._wp ) ; zfast(:,:) = 1._wp ! record presence of fast ice ELSEWHERE ; zfast(:,:) = 0._wp END WHERE CALL iom_put( 'fasticepres', zfast ) DEALLOCATE( zfast ) ENDIF ! - IF( iom_use('icealb') .OR. iom_use('albedo') ) THEN ! ice albedo and surface albedo - ALLOCATE( zalb(jpi,jpj), zmskalb(jpi,jpj) ) + IF( iom_use('icealb') .OR. iom_use('albedo') ) THEN ! ice albedo and surface albedo + ALLOCATE( zalb(A2D(0)), zmskalb(A2D(0)) ) ! ice albedo - WHERE( at_i_b < 1.e-03 ) + WHERE( at_i_b(:,:) < 1.e-03 ) zmskalb(:,:) = 0._wp zalb (:,:) = rn_alb_oce ELSEWHERE zmskalb(:,:) = 1._wp - zalb (:,:) = SUM( alb_ice * a_i_b, dim=3 ) / at_i_b + zalb (:,:) = SUM( alb_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) / at_i_b(:,:) END WHERE CALL iom_put( 'icealb' , zalb * zmskalb + zmiss_val * ( 1._wp - zmskalb ) ) ! ice+ocean albedo - zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + rn_alb_oce * ( 1._wp - at_i_b ) + zalb(:,:) = SUM( alb_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) + rn_alb_oce * ( 1._wp - at_i_b(:,:) ) CALL iom_put( 'albedo' , zalb ) DEALLOCATE( zalb, zmskalb ) ENDIF ! ! --- category-dependent fields --- ! - IF( iom_use('icemask_cat' ) ) CALL iom_put( 'icemask_cat' , zmsk00l ) ! ice mask 0% - IF( iom_use('iceconc_cat' ) ) CALL iom_put( 'iceconc_cat' , a_i * zmsk00l ) ! area for categories - IF( iom_use('icethic_cat' ) ) CALL iom_put( 'icethic_cat' , h_i * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! thickness for categories - IF( iom_use('snwthic_cat' ) ) CALL iom_put( 'snwthic_cat' , h_s * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow depth for categories - IF( iom_use('icesalt_cat' ) ) CALL iom_put( 'icesalt_cat' , s_i * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! salinity for categories - IF( iom_use('iceage_cat' ) ) CALL iom_put( 'iceage_cat' , o_i / rday * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice age - IF( iom_use('icetemp_cat' ) ) CALL iom_put( 'icetemp_cat' , ( SUM( t_i, dim=3 ) * r1_nlay_i - rt0 ) & - & * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice temperature - IF( iom_use('snwtemp_cat' ) ) CALL iom_put( 'snwtemp_cat' , ( SUM( t_s, dim=3 ) * r1_nlay_s - rt0 ) & - & * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow temperature - IF( iom_use('icettop_cat' ) ) CALL iom_put( 'icettop_cat' , ( t_su - rt0 ) * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! surface temperature - IF( iom_use('icebrv_cat' ) ) CALL iom_put( 'icebrv_cat' , bv_i * 100. * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! brine volume - IF( iom_use('iceapnd_cat' ) ) CALL iom_put( 'iceapnd_cat' , a_ip * zmsk00l ) ! melt pond frac for categories - IF( iom_use('icevpnd_cat' ) ) CALL iom_put( 'icevpnd_cat' , v_ip * zmsk00l ) ! melt pond volume for categories - IF( iom_use('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond thickness for categories - IF( iom_use('icehlid_cat' ) ) CALL iom_put( 'icehlid_cat' , h_il * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond lid thickness for categories - IF( iom_use('iceafpnd_cat') ) CALL iom_put( 'iceafpnd_cat', a_ip_frac * zmsk00l ) ! melt pond frac per ice area for categories - IF( iom_use('iceaepnd_cat') ) CALL iom_put( 'iceaepnd_cat', a_ip_eff * zmsk00l ) ! melt pond effective frac for categories - IF( iom_use('icealb_cat' ) ) CALL iom_put( 'icealb_cat' , alb_ice * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice albedo for categories + IF( iom_use('icemask_cat' ) ) CALL iom_put( 'icemask_cat' , zmsk00l ) ! ice mask 0% + IF( iom_use('iceconc_cat' ) ) CALL iom_put( 'iceconc_cat' , a_i(A2D(0),:) * zmsk00l ) ! area for categories + IF( iom_use('icethic_cat' ) ) CALL iom_put( 'icethic_cat' , h_i(A2D(0),:) * zmsk00l + zmiss_val & + & * ( 1._wp - zmsk00l ) ) ! thickness for categories + IF( iom_use('snwthic_cat' ) ) CALL iom_put( 'snwthic_cat' , h_s(A2D(0),:) * zmsksnl + zmiss_val & + & * ( 1._wp - zmsksnl ) ) ! snow depth for categories + IF( iom_use('icesalt_cat' ) ) CALL iom_put( 'icesalt_cat' , s_i(A2D(0),:) * zmsk00l + zmiss_val & + & * ( 1._wp - zmsk00l ) ) ! salinity for categories + IF( iom_use('iceage_cat' ) ) CALL iom_put( 'iceage_cat' , o_i(A2D(0),:) / rday * zmsk00l + zmiss_val & + & * ( 1._wp - zmsk00l ) ) ! ice age + IF( iom_use('icetemp_cat' ) ) CALL iom_put( 'icetemp_cat' , ( SUM( t_i(A2D(0),:,:), dim=3 ) * r1_nlay_i - rt0 ) & + & * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice temperature + IF( iom_use('snwtemp_cat' ) ) CALL iom_put( 'snwtemp_cat' , ( SUM( t_s(A2D(0),:,:), dim=3 ) * r1_nlay_s - rt0 ) & + & * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow temperature + IF( iom_use('icettop_cat' ) ) CALL iom_put( 'icettop_cat' , ( t_su(A2D(0),:) - rt0 ) * zmsk00l + zmiss_val & + & * ( 1._wp - zmsk00l ) ) ! surface temperature + IF( iom_use('icebrv_cat' ) ) CALL iom_put( 'icebrv_cat' , bv_i(:,:,:) * 100. * zmsk00l + zmiss_val & + & * ( 1._wp - zmsk00l ) ) ! brine volume + IF( iom_use('iceapnd_cat' ) ) CALL iom_put( 'iceapnd_cat' , a_ip(A2D(0),:) * zmsk00l ) ! melt pond frac for categories + IF( iom_use('icevpnd_cat' ) ) CALL iom_put( 'icevpnd_cat' , v_ip(A2D(0),:) * zmsk00l ) ! melt pond volume for categories + IF( iom_use('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip(A2D(0),:) * zmsk00l + zmiss_val & + & * ( 1._wp - zmsk00l ) ) ! melt pond thickness for categories + IF( iom_use('icehlid_cat' ) ) CALL iom_put( 'icehlid_cat' , h_il(A2D(0),:) * zmsk00l + zmiss_val & + & * ( 1._wp - zmsk00l ) ) ! melt pond lid thickness for categories + IF( iom_use('iceafpnd_cat') ) CALL iom_put( 'iceafpnd_cat', a_ip_frac(:,:,:) * zmsk00l ) ! melt pond frac per ice area for categories + IF( iom_use('iceaepnd_cat') ) CALL iom_put( 'iceaepnd_cat', a_ip_eff(:,:,:) * zmsk00l ) ! melt pond effective frac for categories + IF( iom_use('icealb_cat' ) ) CALL iom_put( 'icealb_cat' , alb_ice(:,:,:) * zmsk00l + zmiss_val & + & * ( 1._wp - zmsk00l ) ) ! ice albedo for categories !------------------ ! Add-ons for SIMIP !------------------ ! trends - IF( iom_use('dmithd') ) CALL iom_put( 'dmithd', - wfx_bog - wfx_bom - wfx_sum - wfx_sni - wfx_opw - wfx_lam - wfx_res ) ! Sea-ice mass change from thermodynamics + IF( iom_use('dmithd') ) CALL iom_put( 'dmithd', - wfx_bog(:,:) - wfx_bom(:,:) - wfx_sum(:,:) - wfx_sni(:,:) & + & - wfx_opw(:,:) - wfx_lam(:,:) - wfx_res(A2D(0)) ) ! Sea-ice mass change from thermodynamics IF( iom_use('dmidyn') ) CALL iom_put( 'dmidyn', - wfx_dyn + rhoi * diag_trp_vi ) ! Sea-ice mass change from dynamics(kg/m2/s) IF( iom_use('dmiopw') ) CALL iom_put( 'dmiopw', - wfx_opw ) ! Sea-ice mass change through growth in open water IF( iom_use('dmibog') ) CALL iom_put( 'dmibog', - wfx_bog ) ! Sea-ice mass change through basal growth @@ -211,17 +219,23 @@ CONTAINS IF( iom_use('NH_icearea') .OR. iom_use('NH_icevolu') .OR. iom_use('NH_iceextt') .OR. & & iom_use('SH_icearea') .OR. iom_use('SH_icevolu') .OR. iom_use('SH_iceextt') ) THEN ! - WHERE( ff_t(:,:) > 0._wp ) ; z2d(:,:) = 1._wp - ELSEWHERE ; z2d(:,:) = 0. + WHERE( ff_t(A2D(0)) > 0._wp ) ; z2d(:,:) = 1._wp + ELSEWHERE ; z2d(:,:) = 0. END WHERE ! - IF( iom_use('NH_icearea') ) zdiag_area_nh = glob_sum( 'icewri', at_i * z2d * e1e2t * 1.e-12 ) - IF( iom_use('NH_icevolu') ) zdiag_volu_nh = glob_sum( 'icewri', vt_i * z2d * e1e2t * 1.e-12 ) - IF( iom_use('NH_iceextt') ) zdiag_extt_nh = glob_sum( 'icewri', z2d * e1e2t * 1.e-12 * zmsk15 ) + IF( iom_use('NH_icearea') ) zdiag_area_nh = glob_sum( 'icewri', at_i(A2D(0)) * z2d * e1e2t(A2D(0)) & + & * 1.e-12 ) + IF( iom_use('NH_icevolu') ) zdiag_volu_nh = glob_sum( 'icewri', vt_i(A2D(0)) * z2d * e1e2t(A2D(0)) & + & * 1.e-12 ) + IF( iom_use('NH_iceextt') ) zdiag_extt_nh = glob_sum( 'icewri', z2d * e1e2t(A2D(0)) & + & * 1.e-12 * zmsk15 ) ! - IF( iom_use('SH_icearea') ) zdiag_area_sh = glob_sum( 'icewri', at_i * ( 1._wp - z2d ) * e1e2t * 1.e-12 ) - IF( iom_use('SH_icevolu') ) zdiag_volu_sh = glob_sum( 'icewri', vt_i * ( 1._wp - z2d ) * e1e2t * 1.e-12 ) - IF( iom_use('SH_iceextt') ) zdiag_extt_sh = glob_sum( 'icewri', ( 1._wp - z2d ) * e1e2t * 1.e-12 * zmsk15 ) + IF( iom_use('SH_icearea') ) zdiag_area_sh = glob_sum( 'icewri', at_i(A2D(0)) * ( 1._wp - z2d ) * e1e2t(A2D(0)) & + & * 1.e-12 ) + IF( iom_use('SH_icevolu') ) zdiag_volu_sh = glob_sum( 'icewri', vt_i(A2D(0)) * ( 1._wp - z2d ) * e1e2t(A2D(0)) & + & * 1.e-12 ) + IF( iom_use('SH_iceextt') ) zdiag_extt_sh = glob_sum( 'icewri', ( 1._wp - z2d ) * e1e2t(A2D(0)) & + & * 1.e-12 * zmsk15 ) ! CALL iom_put( 'NH_icearea' , zdiag_area_nh ) CALL iom_put( 'NH_icevolu' , zdiag_volu_nh ) @@ -258,25 +272,25 @@ CONTAINS ! !! The file is open in dia_wri_state (ocean routine) - CALL iom_rstput( 0, 0, kid, 'sithic', hm_i ) ! Ice thickness - CALL iom_rstput( 0, 0, kid, 'siconc', at_i ) ! Ice concentration - CALL iom_rstput( 0, 0, kid, 'sitemp', tm_i - rt0 ) ! Ice temperature - CALL iom_rstput( 0, 0, kid, 'sivelu', u_ice ) ! i-Ice speed - CALL iom_rstput( 0, 0, kid, 'sivelv', v_ice ) ! j-Ice speed - CALL iom_rstput( 0, 0, kid, 'sistru', utau_ice ) ! i-Wind stress over ice - CALL iom_rstput( 0, 0, kid, 'sistrv', vtau_ice ) ! i-Wind stress over ice - CALL iom_rstput( 0, 0, kid, 'sisflx', qsr ) ! Solar flx over ocean - CALL iom_rstput( 0, 0, kid, 'sinflx', qns ) ! NonSolar flx over ocean - CALL iom_rstput( 0, 0, kid, 'snwpre', sprecip ) ! Snow precipitation - CALL iom_rstput( 0, 0, kid, 'sisali', sm_i ) ! Ice salinity - CALL iom_rstput( 0, 0, kid, 'sivolu', vt_i ) ! Ice volume - CALL iom_rstput( 0, 0, kid, 'sidive', divu_i*1.0e8 ) ! Ice divergence - CALL iom_rstput( 0, 0, kid, 'si_amp', at_ip ) ! Melt pond fraction - CALL iom_rstput( 0, 0, kid, 'si_vmp', vt_ip ) ! Melt pond volume - CALL iom_rstput( 0, 0, kid, 'sithicat', h_i ) ! Ice thickness - CALL iom_rstput( 0, 0, kid, 'siconcat', a_i ) ! Ice concentration - CALL iom_rstput( 0, 0, kid, 'sisalcat', s_i ) ! Ice salinity - CALL iom_rstput( 0, 0, kid, 'snthicat', h_s ) ! Snw thickness + CALL iom_rstput( 0, 0, kid, 'sithic', hm_i(A2D(0)) ) ! Ice thickness + CALL iom_rstput( 0, 0, kid, 'siconc', at_i(A2D(0)) ) ! Ice concentration + CALL iom_rstput( 0, 0, kid, 'sitemp', tm_i(A2D(0)) - rt0 ) ! Ice temperature + CALL iom_rstput( 0, 0, kid, 'sivelu', u_ice(A2D(0)) ) ! i-Ice speed + CALL iom_rstput( 0, 0, kid, 'sivelv', v_ice(A2D(0)) ) ! j-Ice speed + CALL iom_rstput( 0, 0, kid, 'sistru', utau_ice(A2D(0)) ) ! i-Wind stress over ice + CALL iom_rstput( 0, 0, kid, 'sistrv', vtau_ice(A2D(0)) ) ! i-Wind stress over ice + CALL iom_rstput( 0, 0, kid, 'sisflx', qsr(A2D(0)) ) ! Solar flx over ocean + CALL iom_rstput( 0, 0, kid, 'sinflx', qns(A2D(0)) ) ! NonSolar flx over ocean + CALL iom_rstput( 0, 0, kid, 'snwpre', sprecip(A2D(0)) ) ! Snow precipitation + CALL iom_rstput( 0, 0, kid, 'sisali', sm_i(A2D(0)) ) ! Ice salinity + CALL iom_rstput( 0, 0, kid, 'sivolu', vt_i(A2D(0)) ) ! Ice volume + CALL iom_rstput( 0, 0, kid, 'sidive', divu_i(A2D(0))*1.0e8 ) ! Ice divergence + CALL iom_rstput( 0, 0, kid, 'si_amp', at_ip(A2D(0)) ) ! Melt pond fraction + CALL iom_rstput( 0, 0, kid, 'si_vmp', vt_ip(A2D(0)) ) ! Melt pond volume + CALL iom_rstput( 0, 0, kid, 'sithicat', h_i(A2D(0),:) ) ! Ice thickness + CALL iom_rstput( 0, 0, kid, 'siconcat', a_i(A2D(0),:) ) ! Ice concentration + CALL iom_rstput( 0, 0, kid, 'sisalcat', s_i(A2D(0),:) ) ! Ice salinity + CALL iom_rstput( 0, 0, kid, 'snthicat', h_s(A2D(0),:) ) ! Snw thickness END SUBROUTINE ice_wri_state diff --git a/src/NST/agrif_all_update.F90 b/src/NST/agrif_all_update.F90 index 753bee7cd3ae087392792fe42a48addd6127ab73..bf320ca109426f26fb04a2dbac2b433690e9207a 100644 --- a/src/NST/agrif_all_update.F90 +++ b/src/NST/agrif_all_update.F90 @@ -112,12 +112,10 @@ CONTAINS CALL dom_qco_zgr( Kbb_a, Kmm_a ) #endif #if defined key_si3 - CALL lbc_lnk( 'finalize_lbc_for_agrif', a_i, 'T',1._wp, v_i,'T',1._wp, & - & v_s, 'T',1._wp, sv_i,'T',1._wp, oa_i,'T',1._wp, & - & a_ip,'T',1._wp, v_ip,'T',1._wp, v_il,'T',1._wp ) - CALL lbc_lnk( 'finalize_lbc_for_agrif', t_su,'T',1._wp ) - CALL lbc_lnk( 'finalize_lbc_for_agrif', e_s,'T',1._wp ) - CALL lbc_lnk( 'finalize_lbc_for_agrif', e_i,'T',1._wp ) + CALL lbc_lnk( 'finalize_lbc_for_agrif', a_i, 'T',1._wp, v_i,'T',1._wp, & + & v_s, 'T',1._wp, sv_i,'T',1._wp, oa_i,'T',1._wp, & + & a_ip,'T',1._wp, v_ip,'T',1._wp, v_il,'T',1._wp, t_su,'T',1._wp ) + CALL lbc_lnk( 'finalize_lbc_for_agrif', e_i,'T',1._wp, e_s,'T',1._wp ) CALL lbc_lnk( 'finalize_lbc_for_agrif', u_ice, 'U', -1._wp, v_ice, 'V', -1._wp ) #endif #if defined key_top diff --git a/src/NST/agrif_ice_interp.F90 b/src/NST/agrif_ice_interp.F90 index 13d056d042762efd993f9ea95e8193fd67ad0fff..e51c386844126ab8bf05acf41d9028d62d503124 100644 --- a/src/NST/agrif_ice_interp.F90 +++ b/src/NST/agrif_ice_interp.F90 @@ -59,12 +59,10 @@ CONTAINS Agrif_UseSpecialValue = .TRUE. CALL Agrif_init_variable(tra_iceini_id,procname=interp_tra_ice) ! - CALL lbc_lnk( 'agrif_istate_ice', a_i,'T',1._wp, v_i,'T',1._wp, & - & v_s,'T',1._wp, sv_i,'T',1._wp, oa_i,'T',1._wp, & - & a_ip,'T',1._wp, v_ip,'T',1._wp, v_il,'T',1._wp ) - CALL lbc_lnk( 'agrif_istate_ice', t_su,'T',1._wp ) - CALL lbc_lnk( 'agrif_istate_ice', e_s,'T',1._wp ) - CALL lbc_lnk( 'agrif_istate_ice', e_i,'T',1._wp ) + CALL lbc_lnk( 'agrif_istate_ice', a_i,'T',1._wp, v_i,'T',1._wp, & + & v_s,'T',1._wp, sv_i,'T',1._wp, oa_i,'T',1._wp, & + & a_ip,'T',1._wp, v_ip,'T',1._wp, v_il,'T',1._wp, t_su,'T',1._wp ) + CALL lbc_lnk( 'agrif_istate_ice', e_i,'T',1._wp, e_s,'T',1._wp ) ! ! Set u_ice, v_ice: use_sign_north = .TRUE. diff --git a/src/OCE/DIA/diaar5.F90 b/src/OCE/DIA/diaar5.F90 index c90cea702ea532aee148d302057cc161672bdf5a..da501c5c1d0bbe9643e83410bdeb0eca5f970b32 100644 --- a/src/OCE/DIA/diaar5.F90 +++ b/src/OCE/DIA/diaar5.F90 @@ -269,10 +269,10 @@ CONTAINS ! Work done against stratification by vertical mixing ! Exclude points where rn2 is negative as convection kicks in here and ! work is not being done against stratification - ALLOCATE( zpe(jpi,jpj) ) + ALLOCATE( zpe(A2D(0)) ) zpe(:,:) = 0._wp IF( ln_zdfddm ) THEN - DO_3D( 1, 1, 1, 1, 2, jpk ) + DO_3D( 0, 0, 0, 0, 2, jpk ) IF( rn2(ji,jj,jk) > 0._wp ) THEN zrw = ( gdept(ji,jj,jk,Kmm) - gdepw(ji,jj,jk,Kmm) ) / e3w(ji,jj,jk,Kmm) ! @@ -285,7 +285,7 @@ CONTAINS ENDIF END_3D ELSE - DO_3D( 1, 1, 1, 1, 1, jpk ) + DO_3D( 0, 0, 0, 0, 1, jpk ) zpe(ji,jj) = zpe(ji,jj) + avt(ji,jj,jk) * MIN(0._wp,rn2(ji,jj,jk)) * rho0 * e3w(ji,jj,jk,Kmm) END_3D ENDIF diff --git a/src/OCE/DIA/diahsb.F90 b/src/OCE/DIA/diahsb.F90 index 1039d5c3c98ec1e81b6fba5d45bd650eaf02177f..71c049260d3aa8330fa91dd0988d19939de68184 100644 --- a/src/OCE/DIA/diahsb.F90 +++ b/src/OCE/DIA/diahsb.F90 @@ -85,7 +85,7 @@ CONTAINS REAL(wp) :: z_ssh_hc , z_ssh_sc ! - - REAL(wp), DIMENSION(A2D(0),13) :: ztmp REAL(wp), DIMENSION(A2D(0),jpkm1,4) :: ztmpk - REAL(wp), DIMENSION(17) :: zbg + REAL(wp), DIMENSION(17) :: zbg !!--------------------------------------------------------------------------- IF( ln_timing ) CALL timing_start('dia_hsb') ! @@ -193,12 +193,10 @@ CONTAINS ! ! heat & salt content variation (associated with ssh) IF( ln_linssh ) THEN ! linear free surface case IF( ln_isfcav ) THEN ! ISF case - DO ji = 1, jpi - DO jj = 1, jpj - ztmp(ji,jj,12) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) ) - ztmp(ji,jj,13) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) - ssh_sc_loc_ini(ji,jj) ) - END DO - END DO + DO_2D( 0, 0, 0, 0 ) + ztmp(ji,jj,12) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) ) + ztmp(ji,jj,13) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) - ssh_sc_loc_ini(ji,jj) ) + END_2D ELSE ! no under ice-shelf seas DO_2D( 0, 0, 0, 0 ) ztmp(ji,jj,12) = surf(ji,jj) * ( ts(ji,jj,1,jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) ) @@ -365,26 +363,22 @@ CONTAINS surf_ini(ji,jj) = e1e2t(ji,jj) * tmask_i(ji,jj) ! initial ocean surface ssh_ini(ji,jj) = ssh(ji,jj,Kmm) ! initial ssh END_2D - DO jk = 1, jpk - ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance). - DO_2D( 0, 0, 0, 0 ) - e3t_ini (ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) ! initial vertical scale factors - tmask_ini (ji,jj,jk) = tmask(ji,jj,jk) ! initial mask - hc_loc_ini(ji,jj,jk) = ts(ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) ! initial heat content - sc_loc_ini(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) ! initial salt content - END_2D - END DO + ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance). + DO_3D( 0, 0, 0, 0, 1, jpk ) + e3t_ini (ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) ! initial vertical scale factors + tmask_ini (ji,jj,jk) = tmask(ji,jj,jk) ! initial mask + hc_loc_ini(ji,jj,jk) = ts(ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) ! initial heat content + sc_loc_ini(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) ! initial salt content + END_3D frc_v = 0._wp ! volume trend due to forcing frc_t = 0._wp ! heat content - - - - frc_s = 0._wp ! salt content - - - - IF( ln_linssh ) THEN IF( ln_isfcav ) THEN - DO ji = 1, jpi - DO jj = 1, jpj - ssh_hc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) ! initial heat content in ssh - ssh_sc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) ! initial salt content in ssh - END DO - END DO + DO_2D( 0, 0, 0, 0 ) + ssh_hc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) ! initial heat content in ssh + ssh_sc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) ! initial salt content in ssh + END_2D ELSE DO_2D( 0, 0, 0, 0 ) ssh_hc_loc_ini(ji,jj) = ts(ji,jj,1,jp_tem,Kmm) * ssh(ji,jj,Kmm) ! initial heat content in ssh @@ -466,13 +460,13 @@ CONTAINS ! ------------------- ! ! 1 - Allocate memory ! ! ------------------- ! - ALLOCATE( hc_loc_ini(jpi,jpj,jpk), sc_loc_ini(jpi,jpj,jpk), surf_ini(jpi,jpj), & - & e3t_ini(jpi,jpj,jpk), surf(jpi,jpj), ssh_ini(jpi,jpj), tmask_ini(jpi,jpj,jpk),STAT=ierror ) + ALLOCATE( hc_loc_ini(A2D(0),jpk), sc_loc_ini(A2D(0),jpk), surf_ini(A2D(0)), & + & e3t_ini(A2D(0),jpk), surf(A2D(0)), ssh_ini(A2D(0)), tmask_ini(A2D(0),jpk),STAT=ierror ) IF( ierror > 0 ) THEN CALL ctl_stop( 'dia_hsb_init: unable to allocate hc_loc_ini' ) ; RETURN ENDIF - IF( ln_linssh ) ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj),STAT=ierror ) + IF( ln_linssh ) ALLOCATE( ssh_hc_loc_ini(A2D(0)), ssh_sc_loc_ini(A2D(0)),STAT=ierror ) IF( ierror > 0 ) THEN CALL ctl_stop( 'dia_hsb: unable to allocate ssh_hc_loc_ini' ) ; RETURN ENDIF @@ -482,7 +476,7 @@ CONTAINS ! ----------------------------------------------- ! DO_2D( 0, 0, 0, 0 ) - surf(ji,jj) = e1e2t(ji,jj) * tmask_i(ji,jj) ! masked surface grid cell area + surf(ji,jj) = e1e2t(ji,jj) * smask0_i(ji,jj) ! masked surface grid cell area END_2D surf_tot = glob_sum( 'diahsb', surf(:,:) ) ! total ocean surface area diff --git a/src/OCE/DIU/diu_bulk.F90 b/src/OCE/DIU/diu_bulk.F90 index af1e5adfe07324c0879beae01aab78fab3d9ab9a..aa7e96004cf3ddcd59c296244a0079c798dacc37 100644 --- a/src/OCE/DIU/diu_bulk.F90 +++ b/src/OCE/DIU/diu_bulk.F90 @@ -64,7 +64,7 @@ CONTAINS IF( ln_diurnal ) THEN ! - ALLOCATE( x_dsst(jpi,jpj), x_solfrac(jpi,jpj) ) + ALLOCATE( x_dsst(A2D(0)), x_solfrac(A2D(0)) ) ! x_solfrac = 0._wp ! Initialise the solar fraction x_dsst = 0._wp @@ -92,25 +92,25 @@ CONTAINS !! ** Reference : Refinements to a prognostic scheme of skin sea surface !! temperature, Takaya et al, JGR, 2010 !!---------------------------------------------------------------------- - INTEGER , INTENT(in) :: kt ! time step - REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: psolflux ! solar flux (Watts) - REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: pqflux ! heat (non-solar) flux (Watts) - REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: ptauflux ! wind stress (kg/ m s^2) - REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: prho ! water density (kg/m^3) - REAL(wp) , INTENT(in) :: p_rdt ! time-step - REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pLa ! Langmuir number - REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pthick ! warm layer thickness (m) - REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pcoolthick ! cool skin thickness (m) - REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pmu ! mu parameter - REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: p_hflux_bkginc ! increment to the heat flux - REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: p_fvel_bkginc ! increment to the friction velocity + INTEGER , INTENT(in) :: kt ! time step + REAL(wp), DIMENSION(A2D(0)) , INTENT(in) :: psolflux ! solar flux (Watts) + REAL(wp), DIMENSION(A2D(0)) , INTENT(in) :: pqflux ! heat (non-solar) flux (Watts) + REAL(wp), DIMENSION(A2D(0)) , INTENT(in) :: ptauflux ! wind stress (kg/ m s^2) + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: prho ! water density (kg/m^3) + REAL(wp) , INTENT(in) :: p_rdt ! time-step + REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pLa ! Langmuir number + REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pthick ! warm layer thickness (m) + REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pcoolthick ! cool skin thickness (m) + REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pmu ! mu parameter + REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: p_hflux_bkginc ! increment to the heat flux + REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: p_fvel_bkginc ! increment to the friction velocity ! INTEGER :: ji,jj LOGICAL :: ll_calcfrac - REAL(wp), DIMENSION(jpi,jpj) :: z_fvel ! friction velocity - REAL(wp), DIMENSION(jpi,jpj) :: zthick, zcoolthick, zmu, zla - REAL(wp), DIMENSION(jpi,jpj) :: z_abflux ! absorbed flux - REAL(wp), DIMENSION(jpi,jpj) :: z_fla ! Langmuir function value + REAL(wp), DIMENSION(A2D(0)) :: z_fvel ! friction velocity + REAL(wp), DIMENSION(A2D(0)) :: zthick, zcoolthick, zmu, zla + REAL(wp), DIMENSION(A2D(0)) :: z_abflux ! absorbed flux + REAL(wp), DIMENSION(A2D(0)) :: z_fla ! Langmuir function value !!---------------------------------------------------------------------- ! Set optional arguments to their defaults @@ -129,14 +129,14 @@ CONTAINS ! If not done already, calculate the solar fraction IF ( kt==nit000 ) THEN - DO_2D( 1, 1, 1, 1 ) - IF( ( x_solfrac(ji,jj) == 0._wp ) .AND. ( tmask(ji,jj,1) == 1._wp ) ) & + DO_2D( 0, 0, 0, 0 ) + IF( ( x_solfrac(ji,jj) == 0._wp ) .AND. ( smask0(ji,jj) == 1._wp ) ) & & x_solfrac(ji,jj) = solfrac( zcoolthick(ji,jj),zthick(ji,jj) ) END_2D ENDIF ! convert solar flux and heat flux to absorbed flux - WHERE ( tmask(:,:,1) == 1._wp) + WHERE ( smask0(:,:) == 1._wp) z_abflux(:,:) = ( x_solfrac(:,:) * psolflux (:,:)) + pqflux(:,:) ELSEWHERE z_abflux(:,:) = 0._wp @@ -147,8 +147,8 @@ CONTAINS ENDWHERE ! Calculate the friction velocity - WHERE ( (ptauflux /= 0) .AND. ( tmask(:,:,1) == 1.) ) - z_fvel(:,:) = SQRT( ptauflux(:,:) / prho(:,:) ) + WHERE ( (ptauflux(:,:) /= 0) .AND. ( smask0(:,:) == 1.) ) + z_fvel(:,:) = SQRT( ptauflux(:,:) / prho(A2D(0)) ) ELSEWHERE z_fvel(:,:) = 0._wp ENDWHERE @@ -157,7 +157,7 @@ CONTAINS ! Calculate the Langmuir function value - WHERE ( tmask(:,:,1) == 1.) + WHERE ( smask0(:,:) == 1.) z_fla(:,:) = MAX( 1._wp, zla(:,:)**( -2._wp / 3._wp ) ) ELSEWHERE z_fla(:,:) = 0._wp @@ -176,16 +176,16 @@ CONTAINS IMPLICIT NONE ! Function definition - REAL(wp), DIMENSION(jpi,jpj) :: t_imp + REAL(wp), DIMENSION(A2D(0)) :: t_imp ! Dummy variables - REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_dsst ! Delta SST - REAL(wp), INTENT(IN) :: p_rdt ! Time-step - REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_abflux ! Heat forcing - REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fvel ! Friction velocity - REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fla ! Langmuir number - REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pmu ! Structure parameter - REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pthick ! Layer thickness - REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: prho ! Water density + REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: p_dsst ! Delta SST + REAL(wp), INTENT(IN) :: p_rdt ! Time-step + REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: p_abflux ! Heat forcing + REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: p_fvel ! Friction velocity + REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: p_fla ! Langmuir number + REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: pmu ! Structure parameter + REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: pthick ! Layer thickness + REAL(wp), DIMENSION(jpi,jpj),INTENT(IN) :: prho ! Water density ! Local variables REAL(wp) :: z_olength ! Obukhov length @@ -198,10 +198,10 @@ CONTAINS INTEGER :: ji,jj - DO_2D( 1, 1, 1, 1 ) + DO_2D( 0, 0, 0, 0 ) ! Only calculate outside tmask - IF ( tmask(ji,jj,1) /= 1._wp ) THEN + IF ( smask0(ji,jj) /= 1._wp ) THEN t_imp(ji,jj) = 0._wp CYCLE END IF diff --git a/src/OCE/DIU/diu_coolskin.F90 b/src/OCE/DIU/diu_coolskin.F90 index 594a8b13ade4ae1d7739574244cd3f5b547a1e73..92ec5e84b4ff2164b91511b62dc53710e279b7c8 100644 --- a/src/OCE/DIU/diu_coolskin.F90 +++ b/src/OCE/DIU/diu_coolskin.F90 @@ -59,7 +59,7 @@ MODULE diu_coolskin !! ** Reference : !! !!---------------------------------------------------------------------- - ALLOCATE( x_csdsst(jpi,jpj), x_csthick(jpi,jpj) ) + ALLOCATE( x_csdsst(A2D(0)), x_csthick(A2D(0)) ) x_csdsst = 0. x_csthick = 0. ! @@ -77,16 +77,16 @@ MODULE diu_coolskin !! ** Reference : !!---------------------------------------------------------------------- ! Dummy variables - REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psqflux ! Heat (non-solar)(Watts) - REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: pstauflux ! Wind stress (kg/ m s^2) + REAL(wp), INTENT(IN), DIMENSION(A2D(0)) :: psqflux ! Heat (non-solar)(Watts) + REAL(wp), INTENT(IN), DIMENSION(A2D(0)) :: pstauflux ! Wind stress (kg/ m s^2) REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psrho ! Water density (kg/m^3) REAL(wp), INTENT(IN) :: pDt ! Time-step ! Local variables - REAL(wp), DIMENSION(jpi,jpj) :: z_fv ! Friction velocity - REAL(wp), DIMENSION(jpi,jpj) :: z_gamma ! Dimensionless function of wind speed - REAL(wp), DIMENSION(jpi,jpj) :: z_lamda ! Sauders (dimensionless) proportionality constant - REAL(wp), DIMENSION(jpi,jpj) :: z_wspd ! Wind speed (m/s) + REAL(wp), DIMENSION(A2D(0)) :: z_fv ! Friction velocity + REAL(wp), DIMENSION(A2D(0)) :: z_gamma ! Dimensionless function of wind speed + REAL(wp), DIMENSION(A2D(0)) :: z_lamda ! Sauders (dimensionless) proportionality constant + REAL(wp), DIMENSION(A2D(0)) :: z_wspd ! Wind speed (m/s) REAL(wp) :: z_ztx ! Temporary u wind stress REAL(wp) :: z_zty ! Temporary v wind stress REAL(wp) :: z_zmod ! Temporary total wind stress @@ -96,10 +96,10 @@ MODULE diu_coolskin ! IF( .NOT. (ln_blk .OR. ln_abl) ) CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing") ! - DO_2D( 1, 1, 1, 1 ) + DO_2D( 0, 0, 0, 0 ) ! ! Calcualte wind speed from wind stress and friction velocity - IF( tmask(ji,jj,1) == 1. .AND. pstauflux(ji,jj) /= 0 .AND. psrho(ji,jj) /=0 ) THEN + IF( smask0(ji,jj) == 1. .AND. pstauflux(ji,jj) /= 0 .AND. psrho(ji,jj) /=0 ) THEN z_fv(ji,jj) = SQRT( pstauflux(ji,jj) / psrho(ji,jj) ) z_wspd(ji,jj) = SQRT( pstauflux(ji,jj) / ( pp_cda * pp_rhoa ) ) ELSE @@ -108,28 +108,28 @@ MODULE diu_coolskin ENDIF ! ! Calculate gamma function which is dependent upon wind speed - IF( tmask(ji,jj,1) == 1. ) THEN + IF( smask0(ji,jj) == 1. ) THEN IF( ( z_wspd(ji,jj) <= 7.5 ) ) z_gamma(ji,jj) = ( 0.2 * z_wspd(ji,jj) ) + 0.5 IF( ( z_wspd(ji,jj) > 7.5 ) .AND. ( z_wspd(ji,jj) < 10. ) ) z_gamma(ji,jj) = ( 1.6 * z_wspd(ji,jj) ) - 10. IF( ( z_wspd(ji,jj) >= 10. ) ) z_gamma(ji,jj) = 6. ENDIF ! ! Calculate lamda function - IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 ) THEN + IF( smask0(ji,jj) == 1. .AND. z_fv(ji,jj) /= 0 ) THEN z_lamda(ji,jj) = ( z_fv(ji,jj) * pp_k * pp_C ) / ( z_gamma(ji,jj) * psrho(ji,jj) * pp_cw * pp_h * pp_v ) ELSE z_lamda(ji,jj) = 0. ENDIF ! ! Calculate the cool skin thickness - only when heat flux is out of the ocean - IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 .AND. psqflux(ji,jj) < 0 ) THEN + IF( smask0(ji,jj) == 1. .AND. z_fv(ji,jj) /= 0 .AND. psqflux(ji,jj) < 0 ) THEN x_csthick(ji,jj) = ( z_lamda(ji,jj) * pp_v ) / z_fv(ji,jj) ELSE x_csthick(ji,jj) = 0. ENDIF ! ! Calculate the cool skin correction - only when the heat flux is out of the ocean - IF( tmask(ji,jj,1) == 1. .AND. x_csthick(ji,jj) /= 0. .AND. psqflux(ji,jj) < 0. ) THEN + IF( smask0(ji,jj) == 1. .AND. x_csthick(ji,jj) /= 0. .AND. psqflux(ji,jj) < 0. ) THEN x_csdsst(ji,jj) = ( psqflux(ji,jj) * x_csthick(ji,jj) ) / pp_k ELSE x_csdsst(ji,jj) = 0. diff --git a/src/OCE/DIU/step_diu.F90 b/src/OCE/DIU/step_diu.F90 index ed8baa71733d7265dd1576070314173223b30d8c..a4b44e38d72cfdd4d2e1f5f6b06c9e0eaf2e2bb8 100644 --- a/src/OCE/DIU/step_diu.F90 +++ b/src/OCE/DIU/step_diu.F90 @@ -46,8 +46,7 @@ MODULE step_diu !!---------------------------------------------------------------------- INTEGER :: jk ! dummy loop indices INTEGER :: indic ! error indicator if < 0 - REAL(wp), DIMENSION(jpi,jpj) :: z_fvel_bkginc, z_hflux_bkginc - INTEGER :: Nbb, Nnn, Naa, Nrhs ! local definitions as placeholders for now + INTEGER :: Nbb, Nnn, Naa, Nrhs ! local definitions as placeholders for now !! --------------------------------------------------------------------- IF(ln_diurnal_only) THEN diff --git a/src/OCE/DOM/dom_oce.F90 b/src/OCE/DOM/dom_oce.F90 index 480d3d2fbf0695e6f3388d1814072c7c8832973a..313fc5eb1c2ab7377982170f862046fd255915d5 100644 --- a/src/OCE/DOM/dom_oce.F90 +++ b/src/OCE/DOM/dom_oce.F90 @@ -195,6 +195,7 @@ MODULE dom_oce INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF) REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: smask0 !: surface mask at T-pts on inner domain + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: smask0_i !: equivalent of tmask_i for inner domain REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WU- and WV-pts @@ -327,7 +328,7 @@ CONTAINS ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) ) ! ii = ii+1 - ALLOCATE( tmask_i(jpi,jpj) , smask0(A2D(0)) , & + ALLOCATE( tmask_i(jpi,jpj) , smask0(Nis0-(0):Nie0+(0),Njs0-(0):Nje0+(0)) , smask0_i(Nis0-(0):Nie0+(0),Njs0-(0):Nje0+(0)) , & & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , mbkf(jpi,jpj) , STAT=ierr(ii) ) ! diff --git a/src/OCE/DOM/dommsk.F90 b/src/OCE/DOM/dommsk.F90 index ce234ad277642515bb38c2f21d023e45a9f137fc..dcf95510baedaca121cd5c3ce51e94b62a7528fe 100644 --- a/src/OCE/DOM/dommsk.F90 +++ b/src/OCE/DOM/dommsk.F90 @@ -144,7 +144,7 @@ CONTAINS tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj) END_3D ENDIF - smask0(A2D(0)) = tmask(A2D(0),1) + smask0(:,:) = tmask(A2D(0),1) ! Ocean/land mask at u-, v-, and f-points (computed from tmask) ! ---------------------------------------- @@ -195,7 +195,8 @@ CONTAINS ! -------------------- ! CALL dom_uniq( tmask_i, 'T' ) - tmask_i(:,:) = ssmask(:,:) * tmask_i(:,:) + tmask_i (:,:) = ssmask(:,:) * tmask_i(:,:) + smask0_i(:,:) = tmask_i(A2D(0)) ! Lateral boundary conditions on velocity (modify fmask) ! --------------------------------------- diff --git a/src/OCE/DYN/dynatf.F90 b/src/OCE/DYN/dynatf.F90 index 1a5df99676dabf0493e33335dc2564cc3ce6a8fb..86439f5870953748f9e5c1be814e12cc5be4acbe 100644 --- a/src/OCE/DYN/dynatf.F90 +++ b/src/OCE/DYN/dynatf.F90 @@ -328,7 +328,7 @@ CONTAINS ! IF ( iom_use("utau") ) THEN IF ( ln_drgice_imp.OR.ln_isfcav ) THEN - ALLOCATE(zutau(jpi,jpj)) + ALLOCATE(zutau(A2D(0))) DO_2D( 0, 0, 0, 0 ) jk = miku(ji,jj) zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * rCdU_top(ji,jj) * ( puu(ji-1,jj,jk,Kaa) + puu(ji,jj,jk,Kaa) ) @@ -336,13 +336,13 @@ CONTAINS CALL iom_put( "utau", zutau(:,:) ) DEALLOCATE(zutau) ELSE - CALL iom_put( "utau", utau(:,:) ) + CALL iom_put( "utau", utau(A2D(0)) ) ENDIF ENDIF ! IF ( iom_use("vtau") ) THEN IF ( ln_drgice_imp.OR.ln_isfcav ) THEN - ALLOCATE(zvtau(jpi,jpj)) + ALLOCATE(zvtau(A2D(0))) DO_2D( 0, 0, 0, 0 ) jk = mikv(ji,jj) zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * rCdU_top(ji,jj) * ( pvv(ji,jj-1,jk,Kaa) + pvv(ji,jj,jk,Kaa) ) @@ -350,7 +350,7 @@ CONTAINS CALL iom_put( "vtau", zvtau(:,:) ) DEALLOCATE(zvtau) ELSE - CALL iom_put( "vtau", vtau(:,:) ) + CALL iom_put( "vtau", vtau(A2D(0)) ) ENDIF ENDIF ! diff --git a/src/OCE/DYN/dynatf_qco.F90 b/src/OCE/DYN/dynatf_qco.F90 index 3dd46032e952fc59270a5047155ac46c1570516a..7ec004fb3026de24f4dfde21976263fd6c4c9908 100644 --- a/src/OCE/DYN/dynatf_qco.F90 +++ b/src/OCE/DYN/dynatf_qco.F90 @@ -245,7 +245,7 @@ CONTAINS ! IF ( iom_use("utau") ) THEN IF ( ln_drgice_imp.OR.ln_isfcav ) THEN - ALLOCATE(zutau(jpi,jpj)) + ALLOCATE(zutau(A2D(0))) DO_2D( 0, 0, 0, 0 ) jk = miku(ji,jj) zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * rCdU_top(ji,jj) * ( puu(ji-1,jj,jk,Kaa) + puu(ji,jj,jk,Kaa) ) @@ -253,13 +253,13 @@ CONTAINS CALL iom_put( "utau", zutau(:,:) ) DEALLOCATE(zutau) ELSE - CALL iom_put( "utau", utau(:,:) ) + CALL iom_put( "utau", utau(A2D(0)) ) ENDIF ENDIF ! IF ( iom_use("vtau") ) THEN IF ( ln_drgice_imp.OR.ln_isfcav ) THEN - ALLOCATE(zvtau(jpi,jpj)) + ALLOCATE(zvtau(A2D(0))) DO_2D( 0, 0, 0, 0 ) jk = mikv(ji,jj) zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * rCdU_top(ji,jj) * ( pvv(ji,jj-1,jk,Kaa) + pvv(ji,jj,jk,Kaa) ) @@ -267,7 +267,7 @@ CONTAINS CALL iom_put( "vtau", zvtau(:,:) ) DEALLOCATE(zvtau) ELSE - CALL iom_put( "vtau", vtau(:,:) ) + CALL iom_put( "vtau", vtau(A2D(0)) ) ENDIF ENDIF ! diff --git a/src/OCE/ICB/icbthm.F90 b/src/OCE/ICB/icbthm.F90 index 89999acfdc82c692057c70ee359203e8c4ff9868..cff42aead28e9769ec17e76bbd7cd5122fc480ce 100644 --- a/src/OCE/ICB/icbthm.F90 +++ b/src/OCE/ICB/icbthm.F90 @@ -31,6 +31,8 @@ MODULE icbthm PUBLIC icb_thm ! routine called in icbstp.F90 module + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) !! $Id: icbthm.F90 15088 2021-07-06 13:03:34Z acc $ @@ -287,8 +289,8 @@ CONTAINS ! now use melt and associated heat flux in ocean (or not) ! IF(.NOT. ln_passive_mode ) THEN - emp (:,:) = emp (:,:) - berg_grid%floating_melt(:,:) - qns (:,:) = qns (:,:) + berg_grid%calving_hflx (:,:) + emp (A2D(0)) = emp (A2D(0)) - berg_grid%floating_melt(A2D(0)) + qns (:,:) = qns (:,:) + berg_grid%calving_hflx (A2D(0)) ENDIF ! END SUBROUTINE icb_thm diff --git a/src/OCE/ICB/icbutl.F90 b/src/OCE/ICB/icbutl.F90 index 0666a61439a379af35ad67b2dbfaf895653c1219..11634f30299559500dc4bc2b70108683ff625427 100644 --- a/src/OCE/ICB/icbutl.F90 +++ b/src/OCE/ICB/icbutl.F90 @@ -57,6 +57,7 @@ MODULE icbutl PUBLIC icb_utl_heat ! routine called in icbdia module !! * Substitutions +# include "do_loop_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -101,7 +102,7 @@ CONTAINS CALL lbc_lnk_icb( 'icbutl', ua_e , 'U', -1._wp, 1, 1 ) CALL lbc_lnk_icb( 'icbutl', va_e , 'V', -1._wp, 1, 1 ) #if defined key_si3 - hi_e(1:jpi, 1:jpj) = hm_i (:,:) + hi_e(A2D(0)) = hm_i (:,:) ! clem: something is wrong here (hm_i defined in the interior only) but I do not what to do ui_e(1:jpi, 1:jpj) = u_ice(:,:) vi_e(1:jpi, 1:jpj) = v_ice(:,:) ! diff --git a/src/OCE/IOM/iom.F90 b/src/OCE/IOM/iom.F90 index 6c6d61097e4bc4b34b1c9503b5a713496cc4083e..49433e40e524b91b51945c9ccf365502c1e1a0d9 100644 --- a/src/OCE/IOM/iom.F90 +++ b/src/OCE/IOM/iom.F90 @@ -1202,6 +1202,7 @@ CONTAINS CHARACTER(LEN=1) :: cl_type ! local value of cd_type LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. INTEGER :: inlev ! number of levels for 3D data + INTEGER :: ihls ! local value of the halo size REAL(dp) :: gma, gmi !--------------------------------------------------------------------- CHARACTER(LEN=lc) :: context diff --git a/src/OCE/IOM/prtctl.F90 b/src/OCE/IOM/prtctl.F90 index 863932c9e31deead240a946075fc21e20325d2f5..75103afdd6ab8138c3df99bb38af84622f9f95da 100644 --- a/src/OCE/IOM/prtctl.F90 +++ b/src/OCE/IOM/prtctl.F90 @@ -119,11 +119,11 @@ CONTAINS !! clinfo3 : additional information !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2 - REAL(2*wp), DIMENSION(A2D_T(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1 - REAL(2*wp), DIMENSION(A2D_T(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1 - REAL(2*wp), DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL :: tab4d_1 - REAL(2*wp), DIMENSION(A2D_T(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2 - REAL(2*wp), DIMENSION(A2D_T(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2 + REAL(2*wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 + REAL(2*wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 + REAL(2*wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 + REAL(2*wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 + REAL(2*wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array @@ -135,14 +135,18 @@ CONTAINS CHARACTER(len=30) :: cl1, cl2 CHARACTER(len=6) :: clfmt INTEGER :: jn, jl, kdir - INTEGER :: iis, iie, jjs, jje + INTEGER :: ipi1, ipi2, ipim1, ipim2 + INTEGER :: isht1, isht2, ishtm1, ishtm2 + INTEGER :: ii1s, ii1e, jj1s, jj1e + INTEGER :: ii2s, ii2e, jj2s, jj2e + INTEGER :: iim1s, iim1e, jjm1s, jjm1e + INTEGER :: iim2s, iim2e, jjm2s, jjm2e INTEGER :: itra, inum - INTEGER, DIMENSION(4) :: ishape REAL(2*wp) :: zsum1, zsum2, zvctl1, zvctl2 !!---------------------------------------------------------------------- ! IF( ( ktab2d_1 * ktab3d_1 * ktab4d_1 * ktab2d_2 * ktab3d_2 ) /= 0 ) THEN - CALL ctl_stop( 'prt_ctl is not working with tiles' ) + CALL ctl_stop( 'prt_ctl is a debugging toll that should not be used with tiles' ) ENDIF ! Arrays, scalars initialization @@ -159,29 +163,55 @@ CONTAINS IF( wp == sp ) clfmt = 'D23.16' ! 16 significant numbers IF( wp == dp ) clfmt = 'D41.34' ! 34 significant numbers + + IF( PRESENT(tab2d_1) ) ipi1 = SIZE(tab2d_1,1) + IF( PRESENT(tab3d_1) ) ipi1 = SIZE(tab3d_1,1) + IF( PRESENT(tab4d_1) ) ipi1 = SIZE(tab4d_1,1) + isht1 = ( jpi - ipi1 ) / 2 + + ipi2 = -1 ! default definition + IF( PRESENT(tab2d_2) ) ipi2 = SIZE(tab2d_2,1) + IF( PRESENT(tab3d_2) ) ipi2 = SIZE(tab3d_2,1) + isht2 = ( jpi - ipi2 ) / 2 + + ipim1 = -1 ! default definition + IF( PRESENT(mask1) ) ipim1 = SIZE(mask1,1) + ishtm1 = ( jpi - ipim1 ) / 2 + + ipim2 = -1 ! default definition + IF( PRESENT(mask2) ) ipim2 = SIZE(mask2,1) + ishtm2 = ( jpi - ipim2 ) / 2 ! Loop over each sub-domain, i.e. the total number of processors ijsplt DO jl = 1, SIZE(nall_ictls) - IF( PRESENT(tab2d_1) ) ishape(1:2) = SHAPE(tab2d_1) - IF( PRESENT(tab3d_1) ) ishape(1:3) = SHAPE(tab3d_1) - IF( PRESENT(tab4d_1) ) ishape(1:4) = SHAPE(tab4d_1) - IF( ishape(1) == jpi .AND. ishape(2) == jpj ) THEN - iis = Nis0 ; iie = Nie0 ; jjs = Njs0 ; jje = Nje0 - ELSE - iis = 1 ; iie = ishape(1) ; jjs = 1 ; jje = ishape(2) - ENDIF - iis = MAX( nall_ictls(jl), iis ) - iie = MIN( nall_ictle(jl), iie ) - jjs = MAX( nall_jctls(jl), jjs ) - jje = MIN( nall_jctle(jl), jje ) + + ii1s = MAX( nall_ictls(jl), Nis0 ) - isht1 + ii1e = MIN( nall_ictle(jl), Nie0 ) - isht1 + jj1s = MAX( nall_jctls(jl), Njs0 ) - isht1 + jj1e = MIN( nall_jctle(jl), Nje0 ) - isht1 + + ii2s = MAX( nall_ictls(jl), Nis0 ) - isht2 + ii2e = MIN( nall_ictle(jl), Nie0 ) - isht2 + jj2s = MAX( nall_jctls(jl), Njs0 ) - isht2 + jj2e = MIN( nall_jctle(jl), Nje0 ) - isht2 + + iim1s = MAX( nall_ictls(jl), Nis0 ) - ishtm1 + iim1e = MIN( nall_ictle(jl), Nie0 ) - ishtm1 + jjm1s = MAX( nall_jctls(jl), Njs0 ) - ishtm1 + jjm1e = MIN( nall_jctle(jl), Nje0 ) - ishtm1 + + iim2s = MAX( nall_ictls(jl), Nis0 ) - ishtm2 + iim2e = MIN( nall_ictle(jl), Nie0 ) - ishtm2 + jjm2s = MAX( nall_jctls(jl), Njs0 ) - ishtm2 + jjm2e = MIN( nall_jctle(jl), Nje0 ) - ishtm2 IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl) ELSE ; inum = numprt_oce(jl) ENDIF ! Compute the sum control only where the tile domain and control print area overlap - IF( iie >= iis .AND. jje >= jjs ) THEN + IF( ii1e >= ii1s .AND. jj1e >= jj1s ) THEN DO jn = 1, itra IF( PRESENT(clinfo3) ) THEN @@ -200,32 +230,42 @@ CONTAINS ! 2D arrays IF( PRESENT(tab2d_1) ) THEN - IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(A2D(0),1) ) - ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) ) + IF( PRESENT(mask1) ) THEN + zsum1 = SUM( tab2d_1(ii1s:ii1e,jj1s:jj1e) * mask1(iim1s:iim1e,jjm1s:jjm1e,1) ) + ELSE + zsum1 = SUM( tab2d_1(ii1s:ii1e,jj1s:jj1e) ) ENDIF ENDIF IF( PRESENT(tab2d_2) ) THEN - IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(A2D(0),1) ) - ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) ) + IF( PRESENT(mask2) ) THEN + zsum2 = SUM( tab2d_2(ii2s:ii2e,jj2s:jj2e) * mask2(iim2s:iim2e,jjm2s:jjm2e,1) ) + ELSE + zsum2 = SUM( tab2d_2(ii2s:ii2e,jj2s:jj2e) ) ENDIF ENDIF ! 3D arrays IF( PRESENT(tab3d_1) ) THEN - IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(A2D(0),1:kdir) ) - ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) ) + IF( PRESENT(mask1) ) THEN + zsum1 = SUM( tab3d_1(ii1s:ii1e,jj1s:jj1e,1:kdir) * mask1(iim1s:iim1e,jjm1s:jjm1e,1:kdir) ) + ELSE + zsum1 = SUM( tab3d_1(ii1s:ii1e,jj1s:jj1e,1:kdir) ) ENDIF ENDIF IF( PRESENT(tab3d_2) ) THEN - IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(A2D(0),1:kdir) ) - ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) ) + IF( PRESENT(mask2) ) THEN + zsum2 = SUM( tab3d_2(ii2s:ii2e,jj2s:jj2e,1:kdir) * mask2(iim2s:iim2e,jjm2s:jjm2e,1:kdir) ) + ELSE + zsum2 = SUM( tab3d_2(ii2s:ii2e,jj2s:jj2e,1:kdir) ) ENDIF ENDIF ! 4D arrays IF( PRESENT(tab4d_1) ) THEN - IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(A2D(0),1:kdir) ) - ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) ) + IF( PRESENT(mask1) ) THEN + zsum1 = SUM( tab4d_1(ii1s:ii1e,jj1s:jj1e,1:kdir,jn) * mask1(iim1s:iim1e,jjm1s:jjm1e,1:kdir) ) + ELSE + zsum1 = SUM( tab4d_1(ii1s:ii1e,jj1s:jj1e,1:kdir,jn) ) ENDIF ENDIF diff --git a/src/OCE/LBC/mppini.F90 b/src/OCE/LBC/mppini.F90 index 99df2fa791d7353ee20eede0abea6a8d794ade02..a3d3de962d9439f100f323995546d9a82cc6052c 100644 --- a/src/OCE/LBC/mppini.F90 +++ b/src/OCE/LBC/mppini.F90 @@ -70,7 +70,8 @@ CONTAINS jpi = jpiglo jpj = jpjglo jpk = MAX( 2, jpkglo ) - jpij = jpi*jpj + !jpij = jpi*jpj + jpij = Ni0glo*Nj0glo jpni = 1 jpnj = 1 jpnij = jpni*jpnj @@ -331,7 +332,8 @@ CONTAINS jpi = ijpi(ii,ij) jpj = ijpj(ii,ij) jpk = MAX( 2, jpkglo ) - jpij = jpi*jpj + !jpij = jpi*jpj + jpij = (jpi-2*nn_hls)*(jpj-2*nn_hls) nimpp = iimppt(ii,ij) njmpp = ijmppt(ii,ij) ! diff --git a/src/OCE/SBC/cyclone.F90 b/src/OCE/SBC/cyclone.F90 index 6a66bb02e39f0a709c6e15493114da229b3adb39..175a36633aa4cf80f5b06de59d696619e46a9e4d 100644 --- a/src/OCE/SBC/cyclone.F90 +++ b/src/OCE/SBC/cyclone.F90 @@ -54,9 +54,9 @@ CONTAINS !! ** Action : - open TC data, find TCs for the current timestep !! - for each potential TC, add the winds on the grid !!---------------------------------------------------------------------- - INTEGER , INTENT(in) :: kt ! time step index - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: pwnd_i ! wind speed i-components at T-point ORCA direction - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: pwnd_j ! wind speed j-components at T-point ORCA direction + INTEGER , INTENT(in) :: kt ! time step index + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: pwnd_i ! wind speed i-components at T-point ORCA direction + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: pwnd_j ! wind speed j-components at T-point ORCA direction ! !! INTEGER :: ji, jj , jtc ! loop arguments @@ -79,7 +79,7 @@ CONTAINS REAL(wp) :: zwnd_r, zwnd_t ! radial and tangential components of the wind REAL(wp) :: zvmax ! timestep interpolated vmax REAL(wp) :: zrlon, zrlat ! temporary - REAL(wp), DIMENSION(jpi,jpj) :: zwnd_x, zwnd_y ! zonal and meridional components of the wind + REAL(wp), DIMENSION(A2D(0)) :: zwnd_x, zwnd_y ! zonal and meridional components of the wind REAL(wp), DIMENSION(14,5) :: ztct ! tropical cyclone track data at kt ! CHARACTER(len=100) :: cn_dir ! Root directory for location of files @@ -146,7 +146,7 @@ CONTAINS ! fitted B parameter (Willoughby 2004) zb = 2. - DO_2D( 1, 1, 1, 1 ) + DO_2D( 0, 0, 0, 0 ) ! calc distance between TC center and any point following great circle ! source : http://www.movable-type.co.uk/scripts/latlong.html @@ -207,7 +207,7 @@ CONTAINS zA=0 ENDIF - DO_2D( 1, 1, 1, 1 ) + DO_2D( 0, 0, 0, 0 ) zzrglam = rad * glamt(ji,jj) - zrlon zzrgphi = rad * gphit(ji,jj) diff --git a/src/OCE/SBC/fldread.F90 b/src/OCE/SBC/fldread.F90 index f7a6d90fa6949a2144e762b1a8634f939fcaf8a3..8b84b0c3cee99cdc3bf83c19f79c2031d0edd1c7 100644 --- a/src/OCE/SBC/fldread.F90 +++ b/src/OCE/SBC/fldread.F90 @@ -699,9 +699,10 @@ CONTAINS INTEGER :: imf ! size of the structure sd INTEGER :: ill ! character length INTEGER :: iv ! indice of V component + INTEGER :: ipi, ipj CHARACTER (LEN=100) :: clcomp ! dummy weight name - REAL(wp), DIMENSION(jpi,jpj) :: utmp, vtmp ! temporary arrays for vector rotation - REAL(wp), DIMENSION(:,:,:), POINTER :: dta_u, dta_v ! short cut + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: utmp, vtmp ! temporary arrays for vector rotation + REAL(wp), DIMENSION(:,:,:), POINTER :: dta_u, dta_v ! short cut !!--------------------------------------------------------------------- ! !! (sga: following code should be modified so that pairs arent searched for each time @@ -724,11 +725,14 @@ CONTAINS IF( sd(ju)%ln_tint ) THEN ; dta_u => sd(ju)%fdta(:,:,:,jn) ; dta_v => sd(iv)%fdta(:,:,:,jn) ELSE ; dta_u => sd(ju)%fnow(:,:,: ) ; dta_v => sd(iv)%fnow(:,:,: ) ENDIF + ipi = SIZE(dta_u,1) ; ipj = SIZE(dta_u,2) + ALLOCATE( utmp(ipi,ipj), vtmp(ipi,ipj) ) DO jk = 1, SIZE( sd(ju)%fnow, 3 ) CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->i', utmp(:,:) ) CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->j', vtmp(:,:) ) dta_u(:,:,jk) = utmp(:,:) ; dta_v(:,:,jk) = vtmp(:,:) END DO + DEALLOCATE( utmp, vtmp ) sd(ju)%rotn(jn) = .TRUE. ! vector was rotated IF( lwp .AND. kt == nit000 ) WRITE(numout,*) & & 'fld_read: vector pair ('//TRIM(sd(ju)%clvar)//', '//TRIM(sd(iv)%clvar)//') rotated on to model grid' @@ -1100,7 +1104,7 @@ CONTAINS CHARACTER (len=5) :: clname ! INTEGER , DIMENSION(4) :: ddims INTEGER :: isrc - REAL(wp), DIMENSION(jpi,jpj) :: data_tmp + REAL(wp), DIMENSION(A2D(0)) :: data_tmp !!---------------------------------------------------------------------- ! IF( nxt_wgt > tot_wgts ) THEN @@ -1155,9 +1159,9 @@ CONTAINS ELSE ; ref_wgts(nxt_wgt)%numwgt = 16 ENDIF - ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(Nis0:Nie0,Njs0:Nje0,4) ) - ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(Nis0:Nie0,Njs0:Nje0,4) ) - ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(Nis0:Nie0,Njs0:Nje0,ref_wgts(nxt_wgt)%numwgt) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(A2D(0),4) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(A2D(0),4) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(A2D(0),ref_wgts(nxt_wgt)%numwgt) ) DO jn = 1,4 WRITE(clname,'(a3,i2.2)') 'src',jn @@ -1332,7 +1336,9 @@ CONTAINS INTEGER, DIMENSION(3) :: rec1_lsm, recn_lsm ! temporary arrays for start and length in case of seaoverland INTEGER :: ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2 ! temporary indices INTEGER :: ji, jj, jk, jn, jir, jjr ! loop counters - INTEGER :: ipk + INTEGER :: ipi, ipj, ipk + INTEGER :: iisht, ijsht + INTEGER :: ii, ij INTEGER :: ni, nj ! lengths INTEGER :: jpimin,jpiwid ! temporary indices INTEGER :: jpimin_lsm,jpiwid_lsm ! temporary indices @@ -1343,7 +1349,11 @@ CONTAINS INTEGER :: itmpi,itmpj,itmpz ! lengths REAL(wp),DIMENSION(:,:,:), ALLOCATABLE :: ztmp_fly_dta ! local array of values on input grid !!---------------------------------------------------------------------- + ipi = SIZE(dta, 1) + ipj = SIZE(dta, 2) ipk = SIZE(dta, 3) + iisht = ( jpi - ipi ) / 2 + ijsht = ( jpj - ipj ) / 2 ! !! for weighted interpolation we have weights at four corners of a box surrounding !! a model grid point, each weight is multiplied by a grid value (bilinear case) @@ -1438,7 +1448,9 @@ CONTAINS DO_3D( 0, 0, 0, 0, 1,ipk ) ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1 nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1 - dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn) * ref_wgts(kw)%fly_dta(ni,nj,jk) + ii = ji - iisht + ij = jj - ijsht + dta(ii,ij,jk) = dta(ii,ij,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn) * ref_wgts(kw)%fly_dta(ni,nj,jk) END_3D END DO @@ -1482,7 +1494,9 @@ CONTAINS !!$ DO_3D( 0, 0, 0, 0, 1,ipk ) !!$ ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1 !!$ nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1 -!!$ dta(ji,jj,jk) = dta(ji,jj,jk) & +!!$ ii = ji - iisht +!!$ ij = jj - ijsht +!!$ dta(ii,ij,jk) = dta(ii,ij,jk) & !!$ ! gradient in the i direction !!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * & !!$ & (ref_wgts(kw)%fly_dta(ni+1,nj ,jk) - ref_wgts(kw)%fly_dta(ni-1,nj ,jk)) & @@ -1500,8 +1514,10 @@ CONTAINS DO_3D( 0, 0, 0, 0, 1,ipk ) ni = ref_wgts(kw)%data_jpi(ji,jj,jn) nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + ii = ji - iisht + ij = jj - ijsht ! gradient in the i direction - dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * & + dta(ii,ij,jk) = dta(ii,ij,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * & & (ref_wgts(kw)%fly_dta(ni+2,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj+1,jk)) END_3D END DO @@ -1509,8 +1525,10 @@ CONTAINS DO_3D( 0, 0, 0, 0, 1,ipk ) ni = ref_wgts(kw)%data_jpi(ji,jj,jn) nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + ii = ji - iisht + ij = jj - ijsht ! gradient in the j direction - dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * & + dta(ii,ij,jk) = dta(ii,ij,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * & & (ref_wgts(kw)%fly_dta(ni+1,nj+2,jk) - ref_wgts(kw)%fly_dta(ni+1,nj ,jk)) END_3D END DO @@ -1518,8 +1536,10 @@ CONTAINS DO_3D( 0, 0, 0, 0, 1,ipk ) ni = ref_wgts(kw)%data_jpi(ji,jj,jn) nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + ii = ji - iisht + ij = jj - ijsht ! gradient in the ij direction - dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * ( & + dta(ii,ij,jk) = dta(ii,ij,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * ( & & (ref_wgts(kw)%fly_dta(ni+2,nj+2,jk) - ref_wgts(kw)%fly_dta(ni ,nj+2,jk)) - & & (ref_wgts(kw)%fly_dta(ni+2,nj ,jk) - ref_wgts(kw)%fly_dta(ni ,nj ,jk))) END_3D diff --git a/src/OCE/SBC/geo2ocean.F90 b/src/OCE/SBC/geo2ocean.F90 index 182e5e03073cc458a418e34b745b0fef8f355368..734ce4ef961dcfc0b8041111924a29765de48796 100644 --- a/src/OCE/SBC/geo2ocean.F90 +++ b/src/OCE/SBC/geo2ocean.F90 @@ -57,15 +57,23 @@ CONTAINS !! ** Purpose : Rotate the Repere: Change vector componantes between !! geographic grid <--> stretched coordinates grid. !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxin, pyin ! vector componantes - CHARACTER(len=1), INTENT(in ) :: cd_type ! define the nature of pt2d array grid-points - CHARACTER(len=5), INTENT(in ) :: cdtodo ! type of transpormation: - ! ! 'en->i' = east-north to i-component - ! ! 'en->j' = east-north to j-component - ! ! 'ij->e' = (i,j) components to east - ! ! 'ij->n' = (i,j) components to north - REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: prot + REAL(wp), DIMENSION(:,:), INTENT(in ) :: pxin, pyin ! vector componantes + CHARACTER(len=1), INTENT(in ) :: cd_type ! define the nature of pt2d array grid-points + CHARACTER(len=5), INTENT(in ) :: cdtodo ! type of transpormation: + ! ! 'en->i' = east-north to i-component + ! ! 'en->j' = east-north to j-component + ! ! 'ij->e' = (i,j) components to east + ! ! 'ij->n' = (i,j) components to north + REAL(wp), DIMENSION(:,:), INTENT( out) :: prot + ! + INTEGER :: ipi, ipj, iipi, ijpj + INTEGER :: iisht, ijsht + INTEGER :: ii, ij, ii1, ij1 !!---------------------------------------------------------------------- + ipi = SIZE(pxin, 1) ; ipj = SIZE(pxin, 2) + iisht = ( jpi - ipi ) / 2 ; ijsht = ( jpj - ipj ) / 2 + ii1 = 1 + iisht ; ij1 = 1 + iisht + iipi = ipi + iisht ; ijpj = ipj + ijsht ! IF( lmust_init ) THEN ! at 1st call only: set gsin. & gcos. IF(lwp) WRITE(numout,*) @@ -80,34 +88,50 @@ CONTAINS ! CASE( 'en->i' ) ! east-north to i-component SELECT CASE (cd_type) - CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) + pyin(:,:) * gsint(:,:) - CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) + pyin(:,:) * gsinu(:,:) - CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) + pyin(:,:) * gsinv(:,:) - CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) + pyin(:,:) * gsinf(:,:) + CASE ('T') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcost(ii1:iipi,ij1:ijpj) & + & + pyin(1:ipi,1:ipj) * gsint(ii1:iipi,ij1:ijpj) + CASE ('U') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosu(ii1:iipi,ij1:ijpj) & + & + pyin(1:ipi,1:ipj) * gsinu(ii1:iipi,ij1:ijpj) + CASE ('V') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosv(ii1:iipi,ij1:ijpj) & + & + pyin(1:ipi,1:ipj) * gsinv(ii1:iipi,ij1:ijpj) + CASE ('F') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosf(ii1:iipi,ij1:ijpj) & + & + pyin(1:ipi,1:ipj) * gsinf(ii1:iipi,ij1:ijpj) CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) END SELECT CASE ('en->j') ! east-north to j-component SELECT CASE (cd_type) - CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) - pxin(:,:) * gsint(:,:) - CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) - pxin(:,:) * gsinu(:,:) - CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) - pxin(:,:) * gsinv(:,:) - CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) - pxin(:,:) * gsinf(:,:) + CASE ('T') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcost(ii1:iipi,ij1:ijpj) & + & - pxin(1:ipi,1:ipj) * gsint(ii1:iipi,ij1:ijpj) + CASE ('U') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosu(ii1:iipi,ij1:ijpj) & + & - pxin(1:ipi,1:ipj) * gsinu(ii1:iipi,ij1:ijpj) + CASE ('V') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosv(ii1:iipi,ij1:ijpj) & + & - pxin(1:ipi,1:ipj) * gsinv(ii1:iipi,ij1:ijpj) + CASE ('F') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosf(ii1:iipi,ij1:ijpj) & + & - pxin(1:ipi,1:ipj) * gsinf(ii1:iipi,ij1:ijpj) CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) END SELECT CASE ('ij->e') ! (i,j)-components to east SELECT CASE (cd_type) - CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) - pyin(:,:) * gsint(:,:) - CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) - pyin(:,:) * gsinu(:,:) - CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) - pyin(:,:) * gsinv(:,:) - CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) - pyin(:,:) * gsinf(:,:) + CASE ('T') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcost(ii1:iipi,ij1:ijpj) & + & - pyin(1:ipi,1:ipj) * gsint(ii1:iipi,ij1:ijpj) + CASE ('U') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosu(ii1:iipi,ij1:ijpj) & + & - pyin(1:ipi,1:ipj) * gsinu(ii1:iipi,ij1:ijpj) + CASE ('V') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosv(ii1:iipi,ij1:ijpj) & + & - pyin(1:ipi,1:ipj) * gsinv(ii1:iipi,ij1:ijpj) + CASE ('F') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosf(ii1:iipi,ij1:ijpj) & + & - pyin(1:ipi,1:ipj) * gsinf(ii1:iipi,ij1:ijpj) CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) END SELECT CASE ('ij->n') ! (i,j)-components to north SELECT CASE (cd_type) - CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) + pxin(:,:) * gsint(:,:) - CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) + pxin(:,:) * gsinu(:,:) - CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) + pxin(:,:) * gsinv(:,:) - CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) + pxin(:,:) * gsinf(:,:) + CASE ('T') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcost(ii1:iipi,ij1:ijpj) & + & + pxin(1:ipi,1:ipj) * gsint(ii1:iipi,ij1:ijpj) + CASE ('U') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosu(ii1:iipi,ij1:ijpj) & + & + pxin(1:ipi,1:ipj) * gsinu(ii1:iipi,ij1:ijpj) + CASE ('V') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosv(ii1:iipi,ij1:ijpj) & + & + pxin(1:ipi,1:ipj) * gsinv(ii1:iipi,ij1:ijpj) + CASE ('F') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosf(ii1:iipi,ij1:ijpj) & + & + pxin(1:ipi,1:ipj) * gsinf(ii1:iipi,ij1:ijpj) CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) END SELECT CASE DEFAULT ; CALL ctl_stop( 'rot_rep: Syntax Error in the definition of cdtodo' ) @@ -286,14 +310,17 @@ CONTAINS !! ** Method : Change a vector from geocentric to east/north !! !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxx, pyy, pzz - CHARACTER(len=1) , INTENT(in ) :: cgrid - REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pte, ptn + REAL(wp), DIMENSION(:,:), INTENT(in ) :: pxx, pyy, pzz + CHARACTER(len=1) , INTENT(in ) :: cgrid + REAL(wp), DIMENSION(:,:), INTENT( out) :: pte, ptn ! REAL(wp), PARAMETER :: rpi = 3.141592653e0 REAL(wp), PARAMETER :: rad = rpi / 180.e0 INTEGER :: ig ! INTEGER :: ierr ! local integer + INTEGER :: ipi, ipj, iipi, ijpj + INTEGER :: iisht, ijsht + INTEGER :: ii, ij, ii1, ij1 !!---------------------------------------------------------------------- ! IF( .NOT. ALLOCATED( gsinlon ) ) THEN @@ -345,10 +372,16 @@ CONTAINS CALL ctl_stop( ctmp1 ) END SELECT ! - pte = - gsinlon(:,:,ig) * pxx + gcoslon(:,:,ig) * pyy - ptn = - gcoslon(:,:,ig) * gsinlat(:,:,ig) * pxx & - & - gsinlon(:,:,ig) * gsinlat(:,:,ig) * pyy & - & + gcoslat(:,:,ig) * pzz + ipi = SIZE(pxx, 1) ; ipj = SIZE(pxx, 2) + iisht = ( jpi - ipi ) / 2 ; ijsht = ( jpj - ipj ) / 2 + ii1 = 1 + iisht ; ij1 = 1 + iisht + iipi = ipi + iisht ; ijpj = ipj + ijsht + ! + pte(1:ipi,1:ipj) = - gsinlon(ii1:iipi,ij1:ijpj,ig) * pxx(1:ipi,1:ipj) & + & + gcoslon(ii1:iipi,ij1:ijpj,ig) * pyy(1:ipi,1:ipj) + ptn(1:ipi,1:ipj) = - gcoslon(ii1:iipi,ij1:ijpj,ig) * gsinlat(ii1:iipi,ij1:ijpj,ig) * pxx(1:ipi,1:ipj) & + & - gsinlon(ii1:iipi,ij1:ijpj,ig) * gsinlat(ii1:iipi,ij1:ijpj,ig) * pyy(1:ipi,1:ipj) & + & + gcoslat(ii1:iipi,ij1:ijpj,ig) * pzz(1:ipi,1:ipj) ! END SUBROUTINE geo2oce @@ -371,6 +404,9 @@ CONTAINS REAL(wp), PARAMETER :: rad = rpi / 180.e0_wp INTEGER :: ig ! INTEGER :: ierr ! local integer + INTEGER :: ipi, ipj, iipi, ijpj + INTEGER :: iisht, ijsht + INTEGER :: ii, ij, ii1, ij1 !!---------------------------------------------------------------------- IF( .NOT. ALLOCATED( gsinlon ) ) THEN @@ -422,9 +458,16 @@ CONTAINS CALL ctl_stop( ctmp1 ) END SELECT ! - pxx = - gsinlon(:,:,ig) * pte - gcoslon(:,:,ig) * gsinlat(:,:,ig) * ptn - pyy = gcoslon(:,:,ig) * pte - gsinlon(:,:,ig) * gsinlat(:,:,ig) * ptn - pzz = gcoslat(:,:,ig) * ptn + ipi = SIZE(pte, 1) ; ipj = SIZE(pte, 2) + iisht = ( jpi - ipi ) / 2 ; ijsht = ( jpj - ipj ) / 2 + ii1 = 1 + iisht ; ij1 = 1 + iisht + iipi = ipi + iisht ; ijpj = ipj + ijsht + ! + pxx(1:ipi,1:ipj) = - gsinlon(ii1:iipi,ij1:ijpj,ig) * pte(1:ipi,1:ipj) & + & - gcoslon(ii1:iipi,ij1:ijpj,ig) * gsinlat(ii1:iipi,ij1:ijpj,ig) * ptn(1:ipi,1:ipj) + pyy(1:ipi,1:ipj) = gcoslon(ii1:iipi,ij1:ijpj,ig) * pte(1:ipi,1:ipj) & + & - gsinlon(ii1:iipi,ij1:ijpj,ig) * gsinlat(ii1:iipi,ij1:ijpj,ig) * ptn(1:ipi,1:ipj) + pzz(1:ipi,1:ipj) = gcoslat(ii1:iipi,ij1:ijpj,ig) * ptn(1:ipi,1:ipj) ! END SUBROUTINE oce2geo diff --git a/src/OCE/SBC/ocealb.F90 b/src/OCE/SBC/ocealb.F90 index e40f6f20144ed9754fd2e3a61eb01c28fc6e2367..6ea068681eea63ff75e3e8eece2284e94b676c9e 100644 --- a/src/OCE/SBC/ocealb.F90 +++ b/src/OCE/SBC/ocealb.F90 @@ -17,7 +17,9 @@ MODULE ocealb PRIVATE PUBLIC oce_alb ! routine called by sbccpl - + + !! Substitution +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) !! $Id: ocealb.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ @@ -31,8 +33,8 @@ CONTAINS !! !! ** Purpose : Computation of the albedo of the ocean !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_os ! albedo of ocean under overcast sky - REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_cs ! albedo of ocean under clear sky + REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: palb_os ! albedo of ocean under overcast sky + REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: palb_cs ! albedo of ocean under clear sky !! REAL(wp) :: zcoef REAL(wp) :: rmue = 0.40 ! cosine of local solar altitude diff --git a/src/OCE/SBC/sbc_ice.F90 b/src/OCE/SBC/sbc_ice.F90 index cac087f79246701a2fb0197b1b7e3bf934d87a30..7cde0d4cbfa8195835e2ec1ce1d8b5b3e544ca41 100644 --- a/src/OCE/SBC/sbc_ice.F90 +++ b/src/OCE/SBC/sbc_ice.F90 @@ -103,6 +103,8 @@ MODULE sbc_ice REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2] REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s] + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) !! $Id: sbc_ice.F90 14072 2020-12-04 07:48:38Z laurent $ @@ -114,36 +116,49 @@ CONTAINS !!---------------------------------------------------------------------- !! *** FUNCTION sbc_ice_alloc *** !!---------------------------------------------------------------------- - INTEGER :: ierr(4) + INTEGER :: ierr(5), ii !!---------------------------------------------------------------------- ierr(:) = 0 + ii = 0 - ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) ) + ii = ii + 1 + ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(ii) ) #if defined key_si3 - ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) , & - & qla_ice (jpi,jpj,jpl) , dqla_ice (jpi,jpj,jpl) , & - & dqns_ice(jpi,jpj,jpl) , tn_ice (jpi,jpj,jpl) , alb_ice (jpi,jpj,jpl) , & - & qml_ice (jpi,jpj,jpl) , qcn_ice (jpi,jpj,jpl) , qtr_ice_top(jpi,jpj,jpl) , & - & utau_ice(jpi,jpj) , vtau_ice (jpi,jpj) , wndm_ice (jpi,jpj) , & - & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice (jpi,jpj) , & - & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , & - & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & - & emp_ice (jpi,jpj) , sstfrz (jpi,jpj) , rCdU_ice (jpi,jpj) , STAT= ierr(2) ) + ! ----------------- ! + ! == FULL ARRAYS == ! + ! ----------------- ! + ii = ii + 1 + ALLOCATE( utau_ice(jpi,jpj) , vtau_ice(jpi,jpj) , & + & rCdU_ice(A2D(1)) , STAT= ierr(ii) ) + ! -------------------- ! + ! == REDUCED ARRAYS == ! + ! -------------------- ! + ii = ii + 1 + ALLOCATE( wndm_ice(A2D(0)) , & + & qns_ice (A2D(0),jpl) , qsr_ice (A2D(0),jpl) , & + & qla_ice (A2D(0),jpl) , dqla_ice (A2D(0),jpl) , & + & dqns_ice(A2D(0),jpl) , tn_ice (A2D(0),jpl) , alb_ice (A2D(0),jpl) , & + & qml_ice (A2D(0),jpl) , qcn_ice (A2D(0),jpl) , qtr_ice_top(A2D(0),jpl) , & + & evap_ice(A2D(0),jpl) , devap_ice(A2D(0),jpl) , qprec_ice (A2D(0)) , & + & qemp_ice(A2D(0)) , qevap_ice(A2D(0),jpl) , qemp_oce (A2D(0)) , & + & qns_oce (A2D(0)) , qsr_oce (A2D(0)) , emp_oce (A2D(0)) , & + & emp_ice (A2D(0)) , sstfrz (A2D(0)) , STAT= ierr(ii) ) #endif #if defined key_cice + ii = ii + 1 ALLOCATE( qla_ice(jpi,jpj,1) , qlw_ice(jpi,jpj,1) , qsr_ice(jpi,jpj,1) , & wndi_ice(jpi,jpj) , tatm_ice(jpi,jpj) , qatm_ice(jpi,jpj) , & wndj_ice(jpi,jpj) , nfrzmlt(jpi,jpj) , ss_iou(jpi,jpj) , & ss_iov(jpi,jpj) , fr_iu(jpi,jpj) , fr_iv(jpi,jpj) , & a_i(jpi,jpj,ncat) , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & - STAT= ierr(2) ) + STAT= ierr(ii) ) + ii = ii + 1 IF( ln_cpl ) ALLOCATE( u_ice(jpi,jpj) , tn_ice (jpi,jpj,1) , & & v_ice(jpi,jpj) , alb_ice(jpi,jpj,1) , & & emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , & - & STAT= ierr(3) ) - IF( ln_cpl ) ALLOCATE( h_i(jpi,jpj,jpl) , h_s(jpi,jpj,jpl) , STAT=ierr(4) ) + & h_i(jpi,jpj,jpl) , h_s(jpi,jpj,jpl) ,STAT= ierr(ii) ) #endif sbc_ice_alloc = MAXVAL( ierr ) diff --git a/src/OCE/SBC/sbc_oce.F90 b/src/OCE/SBC/sbc_oce.F90 index f4cd6c97ee11a04d1aa9af9db8dba2b9242fd774..56117e4fd0cca1eed364c22017b3ad138b43e2af 100644 --- a/src/OCE/SBC/sbc_oce.F90 +++ b/src/OCE/SBC/sbc_oce.F90 @@ -121,7 +121,7 @@ MODULE sbc_oce REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s] REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx !: freshwater budget: freezing/melting [Kg/m2/s] REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s] - REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb , fwficb_b !: iceberg melting [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb !: iceberg melting [Kg/m2/s] !! REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sbc_tsc, sbc_tsc_b !: sbc content trend [K.m/s] jpi,jpj,jpts REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_hc , qsr_hc_b !: heat content trend due to qsr flux [K.m/s] jpi,jpj,jpk @@ -175,30 +175,41 @@ CONTAINS !!--------------------------------------------------------------------- !! *** FUNCTION sbc_oce_alloc *** !!--------------------------------------------------------------------- - INTEGER :: ierr(6) + INTEGER :: ierr(8) !!--------------------------------------------------------------------- ierr(:) = 0 ! - ALLOCATE( utau(jpi,jpj) , utau_b(jpi,jpj) , utauU(jpi,jpj) , taum(jpi,jpj) , & - & vtau(jpi,jpj) , vtau_b(jpi,jpj) , vtauV(jpi,jpj) , wndm(jpi,jpj) , rhoa(jpi,jpj) , STAT=ierr(1) ) + ! ----------------- ! + ! == FULL ARRAYS == ! + ! ----------------- ! + ALLOCATE( utau(jpi,jpj) , utau_b(jpi,jpj) , utauU(jpi,jpj) , & + & vtau(jpi,jpj) , vtau_b(jpi,jpj) , vtauV(jpi,jpj) , STAT=ierr(1) ) ! - ALLOCATE( qns_tot(jpi,jpj) , qns (jpi,jpj) , qns_b(jpi,jpj), & - & qsr_tot(jpi,jpj) , qsr (jpi,jpj) , & - & emp (jpi,jpj) , emp_b(jpi,jpj) , & - & sfx (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj), fmmflx(jpi,jpj), STAT=ierr(2) ) + ALLOCATE( emp(jpi,jpj) , emp_b(jpi,jpj) , & + & STAT=ierr(2) ) ! - ALLOCATE( rnf (jpi,jpj) , sbc_tsc (jpi,jpj,jpts) , qsr_hc (jpi,jpj,jpk) , & - & rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , & - & fwficb (jpi,jpj), fwficb_b(jpi,jpj), STAT=ierr(3) ) + ALLOCATE( rnf (jpi,jpj) , rnf_b (jpi,jpj) , & + & fwficb (jpi,jpj) , STAT=ierr(3) ) ! - ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) , & - & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , cloud_fra(jpi,jpj), & + ALLOCATE( fr_i(jpi,jpj) , & & ssu_m (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) , & - & ssv_m (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) + & ssv_m (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , e3t_m(jpi,jpj) , STAT=ierr(4) ) ! - ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) ) + ! -------------------- ! + ! == REDUCED ARRAYS == ! + ! -------------------- ! + ALLOCATE( qns (A2D(0)) , qns_b (A2D(0)) , qsr (A2D(0)) , & + & qns_tot(A2D(0)) , qsr_tot(A2D(0)) , qsr_hc(A2D(0),jpk) , qsr_hc_b(A2D(0),jpk) , STAT=ierr(5) ) + ! + ALLOCATE( sbc_tsc(A2D(0),jpts) , sbc_tsc_b(A2D(0),jpts) , & + & sfx (A2D(0)) , sfx_b(A2D(0)) , emp_tot(A2D(0)), fmmflx(A2D(0)) ,& + & wndm(A2D(0)) , taum (A2D(0)) , STAT=ierr(6) ) + ! + ALLOCATE( tprecip(A2D(0)) , sprecip(A2D(0)) , & + & atm_co2(A2D(0)) , tsk_m (A2D(0)) , cloud_fra(A2D(0)), STAT=ierr(7) ) + + ALLOCATE( rhoa(A2D(0)) , q_air_zt(A2D(0)) , theta_air_zt(A2D(0)) , STAT=ierr(8) ) ! - ALLOCATE( q_air_zt(jpi,jpj) , theta_air_zt(jpi,jpj) , STAT=ierr(6) ) !#LB ! sbc_oce_alloc = MAXVAL( ierr ) CALL mpp_sum ( 'sbc_oce', sbc_oce_alloc ) @@ -224,9 +235,9 @@ CONTAINS INTEGER :: ji, jj ! dummy indices !!--------------------------------------------------------------------- zcoef = 0.5 / ( zrhoa * zcdrag ) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ztau = SQRT( utau(ji,jj)*utau(ji,jj) + vtau(ji,jj)*vtau(ji,jj) ) - wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) + wndm(ji,jj) = SQRT ( ztau * zcoef ) * smask0(ji,jj) END_2D ! END SUBROUTINE sbc_tau2wnd diff --git a/src/OCE/SBC/sbc_phy.F90 b/src/OCE/SBC/sbc_phy.F90 index cabec70fcfda4a096d045c62979b86cb029f02a8..2a845e3a54f0850b3457f4ddee4e039fd1ac4d27 100644 --- a/src/OCE/SBC/sbc_phy.F90 +++ b/src/OCE/SBC/sbc_phy.F90 @@ -223,9 +223,9 @@ CONTAINS FUNCTION virt_temp_vctr( pta, pqa ) - REAL(wp), DIMENSION(jpi,jpj) :: virt_temp_vctr !: virtual temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute or potential air temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: specific humidity of air [kg/kg] + REAL(wp), DIMENSION(A2D(0)) :: virt_temp_vctr !: virtual temperature [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pta !: absolute or potential air temperature [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa !: specific humidity of air [kg/kg] virt_temp_vctr(:,:) = pta(:,:) * (1._wp + rctv0*pqa(:,:)) @@ -290,25 +290,25 @@ CONTAINS !! ** Author: G. Samson, Feb 2021 !!------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: pres_temp_vctr ! air pressure [Pa] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pslp ! sea-level pressure [Pa] - REAL(wp), INTENT(in ) :: pz ! height above surface [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] - INTEGER :: ji, jj ! loop indices - LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence - LOGICAL :: lice ! sea-ice presence + REAL(wp), DIMENSION(A2D(0)) :: pres_temp_vctr ! air pressure [Pa] + REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ) :: pz ! height above surface [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] + INTEGER :: ji, jj ! loop indices + LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence + LOGICAL :: lice ! sea-ice presence lice = .FALSE. IF( PRESENT(l_ice) ) lice = l_ice IF( PRESENT(ptpot) ) THEN - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) pres_temp_vctr(ji,jj) = pres_temp_sclr( pqspe(ji,jj), pslp(ji,jj), pz, ptpot=ptpot(ji,jj), pta=pta(ji,jj), l_ice=lice ) END_2D ELSE - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) pres_temp_vctr(ji,jj) = pres_temp_sclr( pqspe(ji,jj), pslp(ji,jj), pz, pta=pta(ji,jj), l_ice=lice ) END_2D ENDIF @@ -344,12 +344,12 @@ CONTAINS !! ** Author: G. Samson, Feb 2021 !!------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: theta_exner_vctr ! air/surface potential temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta ! air/surface absolute temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! air/surface pressure [Pa] - INTEGER :: ji, jj ! loop indices + REAL(wp), DIMENSION(A2D(0)) :: theta_exner_vctr ! air/surface potential temperature [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pta ! air/surface absolute temperature [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa ! air/surface pressure [Pa] + INTEGER :: ji, jj ! loop indices - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) theta_exner_vctr(ji,jj) = theta_exner_sclr( pta(ji,jj), ppa(ji,jj) ) END_2D @@ -364,10 +364,10 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! pressure in [Pa] - REAL(wp), DIMENSION(jpi,jpj) :: rho_air_vctr ! density of moist air [kg/m^3] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa ! pressure in [Pa] + REAL(wp), DIMENSION(A2D(0)) :: rho_air_vctr ! density of moist air [kg/m^3] !!------------------------------------------------------------------------------- rho_air_vctr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) @@ -412,11 +412,11 @@ CONTAINS FUNCTION visc_air_vctr(ptak) - REAL(wp), DIMENSION(jpi,jpj) :: visc_air_vctr ! kinetic viscosity (m^2/s) - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature in (K) + REAL(wp), DIMENSION(A2D(0)) :: visc_air_vctr ! kinetic viscosity (m^2/s) + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak ! air temperature in (K) INTEGER :: ji, jj ! dummy loop indices - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) visc_air_vctr(ji,jj) = visc_air_sclr( ptak(ji,jj) ) END_2D @@ -431,8 +431,8 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: L_vap_vctr ! latent heat of vaporization [J/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] + REAL(wp), DIMENSION(A2D(0)) :: L_vap_vctr ! latent heat of vaporization [J/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psst ! water temperature [K] !!---------------------------------------------------------------------------------- ! L_vap_vctr = ( 2.501_wp - 0.00237_wp * ( psst(:,:) - rt0) ) * 1.e6_wp @@ -464,8 +464,8 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] - REAL(wp), DIMENSION(jpi,jpj) :: cp_air_vctr ! specific heat of moist air [J/K/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(A2D(0)) :: cp_air_vctr ! specific heat of moist air [J/K/kg] !!------------------------------------------------------------------------------- cp_air_vctr = rCp_dry + rCp_vap * pqa @@ -516,12 +516,12 @@ CONTAINS FUNCTION gamma_moist_vctr( ptak, pqa ) - REAL(wp), DIMENSION(jpi,jpj) :: gamma_moist_vctr - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa + REAL(wp), DIMENSION(A2D(0)) :: gamma_moist_vctr + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa INTEGER :: ji, jj - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) ) END_2D @@ -537,17 +537,17 @@ CONTAINS !! Author: L. Brodeau, June 2019 / AeroBulk !! (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------------ - REAL(wp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Obukhov length) [m^-1] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha !: reference potential temperature of air [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: u*: friction velocity [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts, pqs !: \theta* and q* friction aka turb. scales for temp. and spec. hum. + REAL(wp), DIMENSION(A2D(0)) :: One_on_L !: 1./(Obukhov length) [m^-1] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptha !: reference potential temperature of air [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus !: u*: friction velocity [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pts, pqs !: \theta* and q* friction aka turb. scales for temp. and spec. hum. ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zqa ! local scalar !!------------------------------------------------------------------- ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zqa = (1._wp + rctv0*pqa(ji,jj)) ! ! The main concern is to know whether, the vertical turbulent flux of virtual temperature, < u' theta_v' > is estimated with: @@ -598,27 +598,27 @@ CONTAINS FUNCTION Ri_bulk_vctr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer ) - REAL(wp), DIMENSION(jpi,jpj) :: Ri_bulk_vctr - REAL(wp) , INTENT(in) :: pz ! height above the sea (aka "delta z") [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! SST [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub ! bulk wind speed [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] + REAL(wp), DIMENSION(A2D(0)) :: Ri_bulk_vctr + REAL(wp) , INTENT(in) :: pz ! height above the sea (aka "delta z") [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psst ! SST [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pub ! bulk wind speed [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] !! LOGICAL :: l_ptqa_l_prvd = .FALSE. INTEGER :: ji, jj IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd = .TRUE. IF( l_ptqa_l_prvd ) THEN - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj), & & pta_layer=pta_layer(ji,jj ), pqa_layer=pqa_layer(ji,jj ) ) END_2D ELSE - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj) ) END_2D END IF @@ -652,10 +652,10 @@ CONTAINS END FUNCTION e_sat_sclr FUNCTION e_sat_vctr(ptak) - REAL(wp), DIMENSION(jpi,jpj) :: e_sat_vctr !: vapour pressure at saturation [Pa] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: temperature (K) + REAL(wp), DIMENSION(A2D(0)) :: e_sat_vctr !: vapour pressure at saturation [Pa] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak !: temperature (K) INTEGER :: ji, jj ! dummy loop indices - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) e_sat_vctr(ji,jj) = e_sat_sclr(ptak(ji,jj)) END_2D END FUNCTION e_sat_vctr @@ -681,11 +681,11 @@ CONTAINS FUNCTION e_sat_ice_vctr(ptak) !! Same as "e_sat" but over ice rather than water! - REAL(wp), DIMENSION(jpi,jpj) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak + REAL(wp), DIMENSION(A2D(0)) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak INTEGER :: ji, jj !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) e_sat_ice_vctr(ji,jj) = e_sat_ice_sclr( ptak(ji,jj) ) END_2D @@ -712,11 +712,11 @@ CONTAINS FUNCTION de_sat_dt_ice_vctr(ptak) !! Same as "e_sat" but over ice rather than water! - REAL(wp), DIMENSION(jpi,jpj) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak + REAL(wp), DIMENSION(A2D(0)) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak INTEGER :: ji, jj !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) de_sat_dt_ice_vctr(ji,jj) = de_sat_dt_ice_sclr( ptak(ji,jj) ) END_2D @@ -751,16 +751,16 @@ CONTAINS FUNCTION q_sat_vctr( pta, ppa, l_ice ) - REAL(wp), DIMENSION(jpi,jpj) :: q_sat_vctr - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + REAL(wp), DIMENSION(A2D(0)) :: q_sat_vctr + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa !: atmospheric pressure [Pa] LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice LOGICAL :: lice INTEGER :: ji, jj !!---------------------------------------------------------------------------------- lice = .FALSE. IF( PRESENT(l_ice) ) lice = l_ice - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) q_sat_vctr(ji,jj) = q_sat_sclr( pta(ji,jj) , ppa(ji,jj), l_ice=lice ) END_2D @@ -790,12 +790,12 @@ CONTAINS FUNCTION dq_sat_dt_ice_vctr( pta, ppa ) - REAL(wp), DIMENSION(jpi,jpj) :: dq_sat_dt_ice_vctr - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + REAL(wp), DIMENSION(A2D(0)) :: dq_sat_dt_ice_vctr + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa !: atmospheric pressure [Pa] INTEGER :: ji, jj !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) dq_sat_dt_ice_vctr(ji,jj) = dq_sat_dt_ice_sclr( pta(ji,jj) , ppa(ji,jj) ) END_2D @@ -808,16 +808,16 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: q_air_rh - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prha !: relative humidity [fraction, not %!!!] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: air temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + REAL(wp), DIMENSION(A2D(0)) :: q_air_rh + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: prha !: relative humidity [fraction, not %!!!] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak !: air temperature [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa !: atmospheric pressure [Pa] ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: ze ! local scalar !!---------------------------------------------------------------------------------- ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ze = prha(ji,jj)*e_sat_sclr(ptak(ji,jj)) q_air_rh(ji,jj) = ze*reps0/(ppa(ji,jj) - (1. - reps0)*ze) END_2D @@ -833,29 +833,29 @@ CONTAINS !! and the module of the wind stress => pTau = Tau !! ** Author: L. Brodeau, Sept. 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pust ! u* - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptst ! t* - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqst ! q* - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! air density [kg/m3] + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pust ! u* + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptst ! t* + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqst ! q* + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: prhoa ! air density [kg/m3] ! - REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQns ! non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" [W/m^2]] - REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pQns ! non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" [W/m^2]] + REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pTau ! module of the wind stress [N/m^2] ! - REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(out) :: Qlat + REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(out) :: Qlat ! REAL(wp) :: zdt, zdq, zCd, zCh, zCe, zz0, zQlat, zQsen, zQlw INTEGER :: ji, jj ! dummy loop indices !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zdt = pTa(ji,jj) - pTs(ji,jj) ; zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt ) zdq = pqa(ji,jj) - pqs(ji,jj) ; zdq = SIGN( MAX(ABS(zdq),1.E-9_wp), zdq ) @@ -929,25 +929,25 @@ CONTAINS & pTau, pQsen, pQlat, & & pEvap, pfact_evap ) !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCh - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCe - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCd + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCh + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCe + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] !! - REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] - REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQsen ! [W/m^2] - REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQlat ! [W/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pQsen ! [W/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pQlat ! [W/m^2] !! - REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] - REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) + REAL(wp), DIMENSION(A2D(0)), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] + REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) !! REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap INTEGER :: ji, jj @@ -955,7 +955,7 @@ CONTAINS zfact_evap = 1._wp IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & & pCd(ji,jj), pCh(ji,jj), pCe(ji,jj), & @@ -977,8 +977,8 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: alpha_sw_vctr ! thermal expansion coefficient of sea-water [1/K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] + REAL(wp), DIMENSION(A2D(0)) :: alpha_sw_vctr ! thermal expansion coefficient of sea-water [1/K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psst ! water temperature [K] !!---------------------------------------------------------------------------------- alpha_sw_vctr = 2.1e-5_wp * MAX(psst(:,:)-rt0 + 3.2_wp, 0._wp)**0.79 @@ -1027,16 +1027,16 @@ CONTAINS FUNCTION qlw_net_vctr( pdwlw, pts, l_ice ) - REAL(wp), DIMENSION(jpi,jpj) :: qlw_net_vctr - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts !: surface temperature [K] + REAL(wp), DIMENSION(A2D(0)) :: qlw_net_vctr + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pts !: surface temperature [K] LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice LOGICAL :: lice INTEGER :: ji, jj !!---------------------------------------------------------------------------------- lice = .FALSE. IF( PRESENT(l_ice) ) lice = l_ice - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) qlw_net_vctr(ji,jj) = qlw_net_sclr( pdwlw(ji,jj) , pts(ji,jj), l_ice=lice ) END_2D @@ -1045,10 +1045,10 @@ CONTAINS FUNCTION z0_from_Cd( pzu, pCd, ppsi ) - REAL(wp), DIMENSION(jpi,jpj) :: z0_from_Cd !: roughness length [m] - REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient [] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + REAL(wp), DIMENSION(A2D(0)) :: z0_from_Cd !: roughness length [m] + REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient [] + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] !! !! If pCd is the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given !! If pCd is the drag coefficient (in stable or unstable conditions) then pssi must be provided @@ -1066,10 +1066,10 @@ CONTAINS FUNCTION Cd_from_z0( pzu, pz0, ppsi ) - REAL(wp), DIMENSION(jpi,jpj) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient [] - REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + REAL(wp), DIMENSION(A2D(0)) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient [] + REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0 !: roughness length [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] !! !! If we want to return the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given !! If we want to return the stability-corrected Cd (i.e. in stable or unstable conditions) then pssi must be provided @@ -1111,14 +1111,14 @@ CONTAINS FUNCTION f_m_louis_vctr( pzu, pRib, pCdn, pz0 ) - REAL(wp), DIMENSION(jpi,jpj) :: f_m_louis_vctr - REAL(wp), INTENT(in) :: pzu - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCdn - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 + REAL(wp), DIMENSION(A2D(0)) :: f_m_louis_vctr + REAL(wp), INTENT(in) :: pzu + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pRib + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCdn + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0 INTEGER :: ji, jj - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) f_m_louis_vctr(ji,jj) = f_m_louis_sclr( pzu, pRib(ji,jj), pCdn(ji,jj), pz0(ji,jj) ) END_2D @@ -1150,14 +1150,14 @@ CONTAINS FUNCTION f_h_louis_vctr( pzu, pRib, pChn, pz0 ) - REAL(wp), DIMENSION(jpi,jpj) :: f_h_louis_vctr - REAL(wp), INTENT(in) :: pzu - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pChn - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 + REAL(wp), DIMENSION(A2D(0)) :: f_h_louis_vctr + REAL(wp), INTENT(in) :: pzu + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pRib + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pChn + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0 INTEGER :: ji, jj - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) f_h_louis_vctr(ji,jj) = f_h_louis_sclr( pzu, pRib(ji,jj), pChn(ji,jj), pz0(ji,jj) ) END_2D @@ -1168,11 +1168,11 @@ CONTAINS !!---------------------------------------------------------------------------------- !! Provides the neutral-stability wind speed at 10 m !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s] - REAL(wp), INTENT(in) :: pzu !: measurement heigh of wind speed [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: friction velocity [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + REAL(wp), DIMENSION(A2D(0)) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s] + REAL(wp), INTENT(in) :: pzu !: measurement heigh of wind speed [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus !: friction velocity [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] !!---------------------------------------------------------------------------------- UN10_from_ustar(:,:) = pUzu(:,:) - pus(:,:)/vkarmn * ( LOG(pzu/10._wp) - ppsi(:,:) ) !! @@ -1183,11 +1183,11 @@ CONTAINS !!---------------------------------------------------------------------------------- !! Provides the neutral-stability wind speed at 10 m !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_CD !: [m/s] - REAL(wp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: drag coefficient - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + REAL(wp), DIMENSION(A2D(0)) :: UN10_from_CD !: [m/s] + REAL(wp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCd !: drag coefficient + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] !!---------------------------------------------------------------------------------- !! Reminder: UN10 = u*/vkarmn * log(10/z0) !! and: u* = sqrt(Cd) * Ub @@ -1214,10 +1214,10 @@ CONTAINS !! !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: z0tq_LKB - INTEGER, INTENT(in) :: iflag !: 1 => dealing with temperature; 2 => dealing with humidity - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air} - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length (for momentum) [m] + REAL(wp), DIMENSION(A2D(0)) :: z0tq_LKB + INTEGER, INTENT(in) :: iflag !: 1 => dealing with temperature; 2 => dealing with humidity + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air} + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0 !: roughness length (for momentum) [m] !------------------------------------------------------------------- ! Scalar Re_r relation from Liu et al. REAL(wp), DIMENSION(8,2), PARAMETER :: & @@ -1250,7 +1250,7 @@ CONTAINS z0tq_LKB(:,:) = -999._wp - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zrr = pRer(ji,jj) lfound = .FALSE. diff --git a/src/OCE/SBC/sbcblk.F90 b/src/OCE/SBC/sbcblk.F90 index 397155a58091501fd54d1da3fedcb6bf39d23797..9db8db10fc587b235b162610a378838b0697f01f 100644 --- a/src/OCE/SBC/sbcblk.F90 +++ b/src/OCE/SBC/sbcblk.F90 @@ -124,7 +124,7 @@ MODULE sbcblk ! INTEGER :: nn_iter_algo ! Number of iterations in bulk param. algo ("stable ABL + weak wind" requires more) - REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme) + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme) #if defined key_si3 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: Cd_ice , Ch_ice , Ce_ice !#LB transfert coefficients over ice @@ -180,7 +180,7 @@ CONTAINS !!------------------------------------------------------------------- !! *** ROUTINE sbc_blk_alloc *** !!------------------------------------------------------------------- - ALLOCATE( theta_zu(jpi,jpj), q_zu(jpi,jpj), STAT=sbc_blk_alloc ) + ALLOCATE( theta_zu(A2D(0)), q_zu(A2D(0)), STAT=sbc_blk_alloc ) CALL mpp_sum ( 'sbcblk', sbc_blk_alloc ) IF( sbc_blk_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_alloc: failed to allocate arrays' ) END FUNCTION sbc_blk_alloc @@ -190,8 +190,7 @@ CONTAINS !!------------------------------------------------------------------- !! *** ROUTINE sbc_blk_ice_alloc *** !!------------------------------------------------------------------- - ALLOCATE( Cd_ice (jpi,jpj), Ch_ice (jpi,jpj), Ce_ice (jpi,jpj), & - & theta_zu_i(jpi,jpj), q_zu_i(jpi,jpj), STAT=sbc_blk_ice_alloc ) + ALLOCATE( Cd_ice(A2D(0)), Ch_ice(A2D(0)), Ce_ice(A2D(0)), theta_zu_i(A2D(0)), q_zu_i(A2D(0)), STAT=sbc_blk_ice_alloc ) CALL mpp_sum ( 'sbcblk', sbc_blk_ice_alloc ) IF( sbc_blk_ice_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_ice_alloc: failed to allocate arrays' ) END FUNCTION sbc_blk_ice_alloc @@ -362,7 +361,7 @@ CONTAINS ipka = 1 ENDIF ! - ALLOCATE( sf(jfpr)%fnow(jpi,jpj,ipka) ) + ALLOCATE( sf(jfpr)%fnow(A2D(0),ipka) ) ! IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to default) IF( jfpr == jp_slp ) THEN @@ -384,7 +383,7 @@ CONTAINS CALL ctl_stop( ctmp1 ) ENDIF ELSE !-- used field --! - IF( sf(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(jpi,jpj,ipka,2) ) ! allocate array for temporal interpolation + IF( sf(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(A2D(0),ipka,2) ) ! allocate array for temporal interpolation ! IF( sf(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * sf(jfpr)%freqh), nn_fsbc * NINT(rn_Dt) ) /= 0 ) & & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & @@ -505,7 +504,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: kt ! ocean time step !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp, zpre, ztheta + REAL(wp), DIMENSION(A2D(0)) :: zssq, zcd_du, zsen, zlat, zevp, zpre, ztheta REAL(wp) :: ztst LOGICAL :: llerr !!---------------------------------------------------------------------- @@ -515,7 +514,8 @@ CONTAINS ! Sanity/consistence test on humidity at first time step to detect potential screw-up: IF( kt == nit000 ) THEN ! mean humidity over ocean on proc - ztst = glob_sum( 'sbcblk', sf(jp_humi)%fnow(:,:,1) * e1e2t(:,:) * tmask(:,:,1) ) / glob_sum( 'sbcblk', e1e2t(:,:) * tmask(:,:,1) ) + ztst = glob_sum( 'sbcblk', sf(jp_humi)%fnow(:,:,1) * e1e2t(A2D(0)) * smask0(:,:) ) & + & / glob_sum( 'sbcblk', e1e2t(A2D(0)) * smask0(:,:) ) llerr = .FALSE. SELECT CASE( nhumi ) CASE( np_humi_sph ) ! specific humidity => expect: 0. <= something < 0.065 [kg/kg] (0.061 is saturation at 45degC !!!) @@ -568,7 +568,7 @@ CONTAINS ! CALL blk_oce_1( kt, sf(jp_wndi )%fnow(:,:,1), sf(jp_wndj )%fnow(:,:,1), & ! <<= in & theta_air_zt(:,:), q_air_zt(:,:), & ! <<= in - & sf(jp_slp )%fnow(:,:,1), sst_m, ssu_m, ssv_m, & ! <<= in + & sf(jp_slp )%fnow(:,:,1), sst_m(A2D(0)), ssu_m(A2D(0)), ssv_m(A2D(0)), & ! <<= in & sf(jp_uoatm)%fnow(:,:,1), sf(jp_voatm)%fnow(:,:,1), & ! <<= in & sf(jp_qsr )%fnow(:,:,1), sf(jp_qlw )%fnow(:,:,1), & ! <<= in (wl/cs) & tsk_m, zssq, zcd_du, zsen, zlat, zevp ) ! =>> out @@ -600,7 +600,7 @@ CONTAINS IF( ln_trcdc2dm ) THEN ! diurnal cycle in TOP IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN IF( ln_dm2dc ) THEN - qsr_mean(:,:) = ( 1. - albo ) * sf(jp_qsr)%fnow(:,:,1) * tmask(:,:,1) + qsr_mean(:,:) = ( 1. - albo ) * sf(jp_qsr)%fnow(:,:,1) * smask0(:,:) ELSE ncpl_qsr_freq = sf(jp_qsr)%freqh * 3600 ! qsr_mean will be computed in TOP ENDIF @@ -631,39 +631,39 @@ CONTAINS !! - plat : latent heat flux (W/m^2) !! - pevp : evaporation (mm/s) #lolo !!--------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! time step index - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndi ! atmospheric wind at T-point [m/s] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndj ! atmospheric wind at T-point [m/s] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pqair ! specific humidity at T-points [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: ptair ! potential temperature at T-points [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pslp ! sea-level pressure [Pa] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pst ! surface temperature [Celsius] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pu ! surface current at U-point (i-component) [m/s] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pv ! surface current at V-point (j-component) [m/s] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: puatm ! surface current seen by the atm at T-point (i-component) [m/s] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pvatm ! surface current seen by the atm at T-point (j-component) [m/s] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqsr ! downwelling solar (shortwave) radiation at surface [W/m^2] - REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] - REAL(wp), INTENT( out), DIMENSION(:,:) :: ptsk ! skin temp. (or SST if CS & WL not used) [Celsius] - REAL(wp), INTENT( out), DIMENSION(:,:) :: pssq ! specific humidity at pst [kg/kg] - REAL(wp), INTENT( out), DIMENSION(:,:) :: pcd_du - REAL(wp), INTENT( out), DIMENSION(:,:) :: psen - REAL(wp), INTENT( out), DIMENSION(:,:) :: plat - REAL(wp), INTENT( out), DIMENSION(:,:) :: pevp + INTEGER , INTENT(in ) :: kt ! time step index + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pwndi ! atmospheric wind at T-point [m/s] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pwndj ! atmospheric wind at T-point [m/s] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pqair ! specific humidity at T-points [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: ptair ! potential temperature at T-points [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pst ! surface temperature [Celsius] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pu ! surface current at U-point (i-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pv ! surface current at V-point (j-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: puatm ! surface current seen by the atm at T-point (i-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pvatm ! surface current seen by the atm at T-point (j-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pdqsr ! downwelling solar (shortwave) radiation at surface [W/m^2] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: ptsk ! skin temp. (or SST if CS & WL not used) [Celsius] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: pssq ! specific humidity at pst [kg/kg] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: pcd_du + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: psen + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: plat + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: pevp ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zztmp ! local variable REAL(wp) :: zstmax, zstau #if defined key_cyclone - REAL(wp), DIMENSION(jpi,jpj) :: zwnd_i, zwnd_j ! wind speed components at T-point + REAL(wp), DIMENSION(A2D(0)) :: zwnd_i, zwnd_j ! wind speed components at T-point #endif - REAL(wp), DIMENSION(jpi,jpj) :: zU_zu ! bulk wind speed at height zu [m/s] - REAL(wp), DIMENSION(jpi,jpj) :: zcd_oce ! momentum transfert coefficient over ocean - REAL(wp), DIMENSION(jpi,jpj) :: zch_oce ! sensible heat transfert coefficient over ocean - REAL(wp), DIMENSION(jpi,jpj) :: zce_oce ! latent heat transfert coefficient over ocean - REAL(wp), DIMENSION(jpi,jpj) :: zsspt ! potential sea-surface temperature [K] - REAL(wp), DIMENSION(jpi,jpj) :: zpre, ztabs ! air pressure [Pa] & absolute temperature [K] - REAL(wp), DIMENSION(jpi,jpj) :: zztmp1, zztmp2 + REAL(wp), DIMENSION(A2D(0)) :: zU_zu ! bulk wind speed at height zu [m/s] + REAL(wp), DIMENSION(A2D(0)) :: zcd_oce ! momentum transfert coefficient over ocean + REAL(wp), DIMENSION(A2D(0)) :: zch_oce ! sensible heat transfert coefficient over ocean + REAL(wp), DIMENSION(A2D(0)) :: zce_oce ! latent heat transfert coefficient over ocean + REAL(wp), DIMENSION(A2D(0)) :: zsspt ! potential sea-surface temperature [K] + REAL(wp), DIMENSION(A2D(0)) :: zpre, ztabs ! air pressure [Pa] & absolute temperature [K] + REAL(wp), DIMENSION(A2D(0)) :: zztmp1, zztmp2 !!--------------------------------------------------------------------- ! ! local scalars ( place there for vector optimisation purposes) @@ -685,7 +685,7 @@ CONTAINS zwnd_i(:,:) = 0._wp zwnd_j(:,:) = 0._wp CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zwnd_i(ji,jj) = pwndi(ji,jj) + zwnd_i(ji,jj) zwnd_j(ji,jj) = pwndj(ji,jj) + zwnd_j(ji,jj) ! ... scalar wind at T-point (not masked) @@ -693,7 +693,7 @@ CONTAINS END_2D #else ! ... scalar wind module at T-point (not masked) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) wndm(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) END_2D #endif @@ -703,9 +703,9 @@ CONTAINS ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle IF( ln_dm2dc ) THEN - qsr(:,:) = ( 1._wp - albo ) * sbc_dcy( pdqsr(:,:) ) * tmask(:,:,1) + qsr(:,:) = ( 1._wp - albo ) * sbc_dcy( pdqsr(:,:) ) * smask0(:,:) ELSE - qsr(:,:) = ( 1._wp - albo ) * pdqsr(:,:) * tmask(:,:,1) + qsr(:,:) = ( 1._wp - albo ) * pdqsr(:,:) * smask0(:,:) ENDIF ! ----------------------------------------------------------------------------- ! @@ -755,20 +755,20 @@ CONTAINS END SELECT ! outputs - IF( iom_use('Cd_oce') ) CALL iom_put( "Cd_oce", zcd_oce * tmask(:,:,1) ) - IF( iom_use('Ce_oce') ) CALL iom_put( "Ce_oce", zce_oce * tmask(:,:,1) ) - IF( iom_use('Ch_oce') ) CALL iom_put( "Ch_oce", zch_oce * tmask(:,:,1) ) + IF( iom_use('Cd_oce') ) CALL iom_put( "Cd_oce", zcd_oce * smask0(:,:) ) + IF( iom_use('Ce_oce') ) CALL iom_put( "Ce_oce", zce_oce * smask0(:,:) ) + IF( iom_use('Ch_oce') ) CALL iom_put( "Ch_oce", zch_oce * smask0(:,:) ) !! LB: mainly here for debugging purpose: - IF( iom_use('theta_zt') ) CALL iom_put( "theta_zt", (ptair-rt0) * tmask(:,:,1) ) ! potential temperature at z=zt - IF( iom_use('q_zt') ) CALL iom_put( "q_zt", pqair * tmask(:,:,1) ) ! specific humidity " - IF( iom_use('theta_zu') ) CALL iom_put( "theta_zu", (theta_zu -rt0) * tmask(:,:,1) ) ! potential temperature at z=zu - IF( iom_use('q_zu') ) CALL iom_put( "q_zu", q_zu * tmask(:,:,1) ) ! specific humidity " - IF( iom_use('ssq') ) CALL iom_put( "ssq", pssq * tmask(:,:,1) ) ! saturation specific humidity at z=0 - IF( iom_use('wspd_blk') ) CALL iom_put( "wspd_blk", zU_zu * tmask(:,:,1) ) ! bulk wind speed at z=zu + IF( iom_use('theta_zt') ) CALL iom_put( "theta_zt", (ptair-rt0) * smask0(:,:) ) ! potential temperature at z=zt + IF( iom_use('q_zt') ) CALL iom_put( "q_zt", pqair * smask0(:,:) ) ! specific humidity " + IF( iom_use('theta_zu') ) CALL iom_put( "theta_zu", (theta_zu -rt0) * smask0(:,:) ) ! potential temperature at z=zu + IF( iom_use('q_zu') ) CALL iom_put( "q_zu", q_zu * smask0(:,:) ) ! specific humidity " + IF( iom_use('ssq') ) CALL iom_put( "ssq", pssq * smask0(:,:) ) ! saturation specific humidity at z=0 + IF( iom_use('wspd_blk') ) CALL iom_put( "wspd_blk", zU_zu * smask0(:,:) ) ! bulk wind speed at z=zu ! In the presence of sea-ice we do not use the cool-skin/warm-layer update of zsspt, pssq & ptsk from turb_*() IF( ln_skin_cs .OR. ln_skin_wl ) THEN - WHERE ( fr_i(:,:) > 0.001_wp ) + WHERE ( fr_i(A2D(0)) > 0.001_wp ) zsspt(:,:) = zztmp1(:,:) pssq (:,:) = zztmp2(:,:) END WHERE @@ -781,7 +781,7 @@ CONTAINS IF( ln_abl ) THEN !== ABL formulation ==! multiplication by rho_air and turbulent fluxes computation done in ablstp - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zztmp = zU_zu(ji,jj) wndm(ji,jj) = zztmp ! Store zU_zu in wndm to compute ustar2 in ablmod pcd_du(ji,jj) = zztmp * zcd_oce(ji,jj) @@ -793,7 +793,7 @@ CONTAINS ELSE !== BLK formulation ==! turbulent fluxes computation - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zpre(ji,jj) = pres_temp( q_zu(ji,jj), pslp(ji,jj), rn_zu, ptpot=theta_zu(ji,jj), pta=ztabs(ji,jj) ) rhoa(ji,jj) = rho_air( ztabs(ji,jj), q_zu(ji,jj), zpre(ji,jj) ) END_2D @@ -804,12 +804,12 @@ CONTAINS & taum(:,:), psen(:,:), plat(:,:), & & pEvap=pevp(:,:), pfact_evap=rn_efac ) - psen(:,:) = psen(:,:) * tmask(:,:,1) - plat(:,:) = plat(:,:) * tmask(:,:,1) - taum(:,:) = taum(:,:) * tmask(:,:,1) - pevp(:,:) = pevp(:,:) * tmask(:,:,1) + psen(:,:) = psen(:,:) * smask0(:,:) + plat(:,:) = plat(:,:) * smask0(:,:) + taum(:,:) = taum(:,:) * smask0(:,:) + pevp(:,:) = pevp(:,:) * smask0(:,:) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF( wndm(ji,jj) > 0._wp ) THEN zztmp = taum(ji,jj) / wndm(ji,jj) #if defined key_cyclone @@ -828,19 +828,19 @@ CONTAINS IF( ln_crt_fbk ) THEN ! aply eq. 10 and 11 of Renault et al. 2020 (doi: 10.1029/2019MS001715) zstmax = MIN( rn_stau_a * 3._wp + rn_stau_b, 0._wp ) ! set the max value of Stau corresponding to a wind of 3 m/s (<0) DO_2D( 0, 0, 0, 0 ) - zstau = MIN( rn_stau_a * wndm(ji,jj) + rn_stau_b, zstmax ) * tmask(ji,jj,1) ! stau (<0) must be smaller than zstmax + zstau = MIN( rn_stau_a * wndm(ji,jj) + rn_stau_b, zstmax ) * smask0(ji,jj) ! stau (<0) must be smaller than zstmax utau(ji,jj) = utau(ji,jj) + zstau * ( 0.5_wp * ( pu(ji-1,jj ) + pu(ji,jj) ) - puatm(ji,jj) ) vtau(ji,jj) = vtau(ji,jj) + zstau * ( 0.5_wp * ( pv(ji ,jj-1) + pv(ji,jj) ) - pvatm(ji,jj) ) taum(ji,jj) = SQRT( utau(ji,jj) * utau(ji,jj) + vtau(ji,jj) * vtau(ji,jj) ) END_2D - CALL lbc_lnk( 'sbcblk', utau, 'T', -1._wp, vtau, 'T', -1._wp, taum, 'T', 1._wp ) + CALL lbc_lnk( 'sbcblk', utau, 'T', -1._wp, vtau, 'T', -1._wp ) ENDIF ! Saving open-ocean wind-stress (module and components) CALL iom_put( "taum_oce", taum(:,:) ) ! wind stress module ! ! LB: These 2 lines below mostly here for 'STATION_ASF' test-case - CALL iom_put( "utau_oce", utau(:,:) ) ! utau - CALL iom_put( "vtau_oce", vtau(:,:) ) ! vtau + CALL iom_put( "utau_oce", utau(A2D(0)) ) ! utau + CALL iom_put( "vtau_oce", vtau(A2D(0)) ) ! vtau IF(sn_cfctl%l_prtctl) THEN CALL prt_ctl( tab2d_1=pssq , clinfo1=' blk_oce_1: pssq : ', mask1=tmask ) @@ -852,7 +852,7 @@ CONTAINS ! ENDIF ! ln_blk / ln_abl - ptsk(:,:) = ( ptsk(:,:) - rt0 ) * tmask(:,:,1) ! Back to Celsius + ptsk(:,:) = ( ptsk(:,:) - rt0 ) * smask0(:,:) ! Back to Celsius IF( ln_skin_cs .OR. ln_skin_wl ) THEN CALL iom_put( "t_skin" , ptsk ) ! T_skin in Celsius @@ -879,60 +879,66 @@ CONTAINS !! - qns : Non Solar heat flux over the ocean (W/m2) !! - emp : evaporation minus precipitation (kg/m2/s) !!--------------------------------------------------------------------- - REAL(wp), INTENT(in), DIMENSION(:,:) :: ptair ! potential temperature of air #LB: confirm! - REAL(wp), INTENT(in), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] - REAL(wp), INTENT(in), DIMENSION(:,:) :: pprec - REAL(wp), INTENT(in), DIMENSION(:,:) :: psnow - REAL(wp), INTENT(in), DIMENSION(:,:) :: ptsk ! SKIN surface temperature [Celsius] - REAL(wp), INTENT(in), DIMENSION(:,:) :: psen - REAL(wp), INTENT(in), DIMENSION(:,:) :: plat - REAL(wp), INTENT(in), DIMENSION(:,:) :: pevp + REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: ptair ! potential temperature of air #LB: confirm! + REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] + REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: pprec + REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: psnow + REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: ptsk ! SKIN surface temperature [Celsius] + REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: psen + REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: plat + REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: pevp ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zztmp,zz1,zz2,zz3 ! local variable - REAL(wp), DIMENSION(jpi,jpj) :: zqlw ! net long wave radiative heat flux - REAL(wp), DIMENSION(jpi,jpj) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg) + REAL(wp), DIMENSION(A2D(0)) :: zqlw ! net long wave radiative heat flux + REAL(wp), DIMENSION(A2D(0)) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg) !!--------------------------------------------------------------------- ! - ! Heat content per unit mass (J/kg) - zcptrain(:,:) = ( ptair - rt0 ) * rcp * tmask(:,:,1) - zcptsnw (:,:) = ( MIN( ptair, rt0 ) - rt0 ) * rcpi * tmask(:,:,1) - zcptn (:,:) = ptsk * rcp * tmask(:,:,1) - ! + DO_2D( 0, 0, 0, 0 ) + ! Heat content per unit mass (J/kg) + zcptrain(ji,jj) = ( ptair(ji,jj) - rt0 ) * rcp * smask0(ji,jj) + zcptsnw (ji,jj) = ( MIN( ptair(ji,jj), rt0 ) - rt0 ) * rcpi * smask0(ji,jj) + zcptn (ji,jj) = ptsk (ji,jj) * rcp * smask0(ji,jj) + ! + END_2D ! ----------------------------------------------------------------------------- ! ! III Net longwave radiative FLUX ! ! ----------------------------------------------------------------------------- ! !! #LB: now moved after Turbulent fluxes because must use the skin temperature rather than bulk SST !! (ptsk is skin temperature if ln_skin_cs==.TRUE. .OR. ln_skin_wl==.TRUE.) zqlw(:,:) = qlw_net( pdqlw(:,:), ptsk(:,:)+rt0 ) - + ! ----------------------------------------------------------------------------- ! ! IV Total FLUXES ! ! ----------------------------------------------------------------------------- ! ! - emp (:,:) = ( pevp(:,:) - pprec(:,:) * rn_pfac ) * tmask(:,:,1) ! mass flux (evap. - precip.) - ! - qns(:,:) = zqlw(:,:) + psen(:,:) + plat(:,:) & ! Downward Non Solar - & - psnow(:,:) * rn_pfac * rLfus & ! remove latent melting heat for solid precip - & - pevp(:,:) * zcptn(:,:) & ! remove evap heat content at SST - & + ( pprec(:,:) - psnow(:,:) ) * rn_pfac * zcptrain(:,:) & ! add liquid precip heat content at Tair - & + psnow(:,:) * rn_pfac * zcptsnw(:,:) ! add solid precip heat content at min(Tair,Tsnow) - qns(:,:) = qns(:,:) * tmask(:,:,1) + DO_2D( 0, 0, 0, 0 ) + emp (ji,jj) = ( pevp(ji,jj) - pprec(ji,jj) * rn_pfac ) * smask0(ji,jj) ! mass flux (evap. - precip.) + ! + qns(ji,jj) = zqlw(ji,jj) + psen(ji,jj) + plat(ji,jj) & ! Downward Non Solar + & - psnow(ji,jj) * rn_pfac * rLfus & ! remove latent melting heat for solid precip + & - pevp(ji,jj) * zcptn(ji,jj) & ! remove evap heat content at SST + & + ( pprec(ji,jj) - psnow(ji,jj) ) * rn_pfac * zcptrain(ji,jj) & ! add liquid precip heat content at Tair + & + psnow(ji,jj) * rn_pfac * zcptsnw(ji,jj) ! add solid precip heat content at min(Tair,Tsnow) + qns(ji,jj) = qns(ji,jj) * smask0(ji,jj) + END_2D ! #if defined key_si3 IF ( nn_ice == 2 ) THEN - qns_oce(:,:) = zqlw(:,:) + psen(:,:) + plat(:,:) ! non solar without emp (only needed by SI3) - qsr_oce(:,:) = qsr(:,:) + DO_2D( 0, 0, 0, 0 ) + qns_oce(ji,jj) = zqlw(ji,jj) + psen(ji,jj) + plat(ji,jj) ! non solar without emp (only needed by SI3) + qsr_oce(ji,jj) = qsr(ji,jj) + END_2D ENDIF #endif ! - CALL iom_put( "rho_air" , rhoa*tmask(:,:,1) ) ! output air density [kg/m^3] + CALL iom_put( "rho_air" , rhoa*smask0(:,:) ) ! output air density [kg/m^3] CALL iom_put( "evap_oce" , pevp ) ! evaporation CALL iom_put( "qlw_oce" , zqlw ) ! output downward longwave heat over the ocean CALL iom_put( "qsb_oce" , psen ) ! output downward sensible heat over the ocean CALL iom_put( "qla_oce" , plat ) ! output downward latent heat over the ocean - tprecip(:,:) = pprec(:,:) * rn_pfac * tmask(:,:,1) ! output total precipitation [kg/m2/s] - sprecip(:,:) = psnow(:,:) * rn_pfac * tmask(:,:,1) ! output solid precipitation [kg/m2/s] + tprecip(:,:) = pprec(:,:) * rn_pfac * smask0(:,:) ! output total precipitation [kg/m2/s] + sprecip(:,:) = psnow(:,:) * rn_pfac * smask0(:,:) ! output solid precipitation [kg/m2/s] CALL iom_put( 'snowpre', sprecip ) ! Snow CALL iom_put( 'precip' , tprecip ) ! Total precipitation ! @@ -974,29 +980,29 @@ CONTAINS !! formulea, ice variables and read atmospheric fields. !! NB: ice drag coefficient is assumed to be a constant !!--------------------------------------------------------------------- - REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pslp ! sea-level pressure [Pa] - REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pwndi ! atmospheric wind at T-point [m/s] - REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pwndj ! atmospheric wind at T-point [m/s] - REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: ptair ! atmospheric potential temperature at T-point [K] - REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pqair ! atmospheric specific humidity at T-point [kg/kg] - REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: puice ! sea-ice velocity on I or C grid [m/s] - REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pvice ! " - REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: ptsui ! sea-ice surface temperature [K] - REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: putaui ! if ln_blk - REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pvtaui ! if ln_blk - REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pseni ! if ln_abl - REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pevpi ! if ln_abl - REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pssqi ! if ln_abl - REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pcd_dui ! if ln_abl + REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: pslp ! sea-level pressure [Pa] + REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: pwndi ! atmospheric wind at T-point [m/s] + REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: pwndj ! atmospheric wind at T-point [m/s] + REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: ptair ! atmospheric potential temperature at T-point [K] + REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: pqair ! atmospheric specific humidity at T-point [kg/kg] + REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: puice ! sea-ice velocity on I or C grid [m/s] + REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: pvice ! " + REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: ptsui ! sea-ice surface temperature [K] + REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: putaui ! if ln_blk + REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pvtaui ! if ln_blk + REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pseni ! if ln_abl + REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pevpi ! if ln_abl + REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pssqi ! if ln_abl + REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pcd_dui ! if ln_abl ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zztmp ! temporary scalars - REAL(wp), DIMENSION(jpi,jpj) :: ztmp, zsipt ! temporary array - REAL(wp), DIMENSION(jpi,jpj) :: zmsk00 ! O% concentration ice mask + REAL(wp), DIMENSION(A2D(0)) :: ztmp, zsipt ! temporary array + REAL(wp), DIMENSION(A2D(0)) :: zmsk00 ! O% concentration ice mask !!--------------------------------------------------------------------- ! ! treshold for outputs - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , fr_i(ji,jj) - 1.e-6_wp ) ) ! 1 if ice, 0 if no ice END_2D @@ -1004,7 +1010,7 @@ CONTAINS ! Wind module relative to the moving ice ( U10m - U_ice ) ! ! ------------------------------------------------------------ ! ! C-grid ice dynamics : U & V-points (same as ocean) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) wndm_ice(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) END_2D ! @@ -1030,12 +1036,12 @@ CONTAINS ! CASE( np_ice_lu12 ) ! from Lupkes(2012) equations ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ - CALL turb_ice_lu12( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i, & + CALL turb_ice_lu12( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i(A2D(0)), & & Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i ) ! CASE( np_ice_lg15 ) ! from Lupkes and Gryanik (2015) equations ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ - CALL turb_ice_lg15( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i, & + CALL turb_ice_lg15( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i(A2D(0)), & & Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i ) ! END SELECT @@ -1046,7 +1052,7 @@ CONTAINS ! Wind stress relative to nonmoving ice ( U10m ) ! ! ---------------------------------------------------- ! ! supress moving ice in wind stress computation as we don't know how to do it properly... - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zztmp = rhoa(ji,jj) * Cd_ice(ji,jj) * wndm_ice(ji,jj) putaui(ji,jj) = zztmp * pwndi(ji,jj) pvtaui(ji,jj) = zztmp * pwndj(ji,jj) @@ -1063,7 +1069,7 @@ CONTAINS & , tab2d_2=pvtaui , clinfo2=' pvtaui : ', mask2=tmask ) ELSE ! ln_abl - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) pcd_dui(ji,jj) = wndm_ice(ji,jj) * Cd_ice(ji,jj) pseni (ji,jj) = wndm_ice(ji,jj) * Ch_ice(ji,jj) pevpi (ji,jj) = wndm_ice(ji,jj) * Ce_ice(ji,jj) @@ -1094,30 +1100,30 @@ CONTAINS !! !! caution : the net upward water flux has with mm/day unit !!--------------------------------------------------------------------- - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptsu ! sea ice surface temperature [K] - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: palb ! ice albedo (all skies) - REAL(wp), DIMENSION(:,: ), INTENT(in) :: ptair ! potential temperature of air #LB: okay ??? - REAL(wp), DIMENSION(:,: ), INTENT(in) :: pqair ! specific humidity of air - REAL(wp), DIMENSION(:,: ), INTENT(in) :: pslp - REAL(wp), DIMENSION(:,: ), INTENT(in) :: pdqlw - REAL(wp), DIMENSION(:,: ), INTENT(in) :: pprec - REAL(wp), DIMENSION(:,: ), INTENT(in) :: psnow + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in) :: ptsu ! sea ice surface temperature [K] + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in) :: phs ! snow thickness + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in) :: phi ! ice thickness + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in) :: palb ! ice albedo (all skies) + REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: ptair ! potential temperature of air #LB: okay ??? + REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: pqair ! specific humidity of air + REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: pslp + REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: pdqlw + REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: pprec + REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: psnow !! INTEGER :: ji, jj, jl ! dummy loop indices REAL(wp) :: zst, zst3, zsq, zsipt ! local variable REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - - REAL(wp) :: zztmp, zzblk, zztmp1, z1_rLsub ! - - REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmsk ! temporary mask for prt_ctl - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qlw ! long wave heat flux over ice - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qsb ! sensible heat flux over ice - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqlw ! long wave heat sensitivity over ice - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqsb ! sensible heat sensitivity over ice - REAL(wp), DIMENSION(jpi,jpj) :: zevap, zsnw ! evaporation and snw distribution after wind blowing (SI3) - REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2 - REAL(wp), DIMENSION(jpi,jpj) :: ztri - REAL(wp), DIMENSION(jpi,jpj) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg) + REAL(wp), DIMENSION(A2D(0),jpl) :: z_qlw ! long wave heat flux over ice + REAL(wp), DIMENSION(A2D(0),jpl) :: z_qsb ! sensible heat flux over ice + REAL(wp), DIMENSION(A2D(0),jpl) :: z_dqlw ! long wave heat sensitivity over ice + REAL(wp), DIMENSION(A2D(0),jpl) :: z_dqsb ! sensible heat sensitivity over ice + REAL(wp), DIMENSION(A2D(0)) :: zevap, zsnw ! evaporation and snw distribution after wind blowing (SI3) + REAL(wp), DIMENSION(A2D(0)) :: ztmp, ztmp2 + REAL(wp), DIMENSION(A2D(0)) :: ztri + REAL(wp), DIMENSION(A2D(0)) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg) !!--------------------------------------------------------------------- ! zcoef_dqlw = 4._wp * emiss_i * stefan ! local scalars @@ -1125,14 +1131,14 @@ CONTAINS dqla_ice(:,:,:) = 0._wp ! Heat content per unit mass (J/kg) - zcptrain(:,:) = ( ptair - rt0 ) * rcp * tmask(:,:,1) - zcptsnw (:,:) = ( MIN( ptair, rt0 ) - rt0 ) * rcpi * tmask(:,:,1) - zcptn (:,:) = sst_m * rcp * tmask(:,:,1) + zcptrain(:,:) = ( ptair(:,:) - rt0 ) * rcp * smask0(:,:) + zcptsnw (:,:) = ( MIN( ptair(:,:), rt0 ) - rt0 ) * rcpi * smask0(:,:) + zcptn (:,:) = sst_m(A2D(0)) * rcp * smask0(:,:) ! ! ! ========================== ! DO jl = 1, jpl ! Loop over ice categories ! ! ! ========================== ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zst = ptsu(ji,jj,jl) ! surface temperature of sea-ice [K] zsq = q_sat( zst, pslp(ji,jj), l_ice=.TRUE. ) ! surface saturation specific humidity when ice present @@ -1146,7 +1152,7 @@ CONTAINS ! Long Wave (lw) zst3 = zst * zst * zst - z_qlw(ji,jj,jl) = emiss_i * ( pdqlw(ji,jj) - stefan * zst * zst3 ) * tmask(ji,jj,1) + z_qlw(ji,jj,jl) = emiss_i * ( pdqlw(ji,jj) - stefan * zst * zst3 ) * smask0(ji,jj) ! lw sensitivity z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3 @@ -1173,7 +1179,6 @@ CONTAINS !qla_ice( ji,jj,jl) = zztmp1 * (zsq - q_zu_i(ji,jj)) !dqla_ice(ji,jj,jl) = zztmp1 * dq_sat_dt_ice(zst, pslp(ji,jj)) ! ==> Qlat sensitivity (dQlat/dT) - ! ----------------------------! ! III Total FLUXES ! ! ----------------------------! @@ -1186,43 +1191,48 @@ CONTAINS ! END DO ! - tprecip(:,:) = pprec(:,:) * rn_pfac * tmask(:,:,1) ! total precipitation [kg/m2/s] - sprecip(:,:) = psnow(:,:) * rn_pfac * tmask(:,:,1) ! solid precipitation [kg/m2/s] - CALL iom_put( 'snowpre', sprecip ) ! Snow precipitation - CALL iom_put( 'precip' , tprecip ) ! Total precipitation - - ! --- evaporation --- ! z1_rLsub = 1._wp / rLsub - evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_rLsub ! sublimation - devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_rLsub ! d(sublimation)/dT - zevap (:,:) = emp(:,:) + tprecip(:,:) ! evaporation over ocean !LB: removed rn_efac here, correct??? + DO_2D( 0, 0, 0, 0 ) + ! --- precipitation --- ! + tprecip(ji,jj) = pprec(ji,jj) * rn_pfac * smask0(ji,jj) ! total precipitation [kg/m2/s] + sprecip(ji,jj) = psnow(ji,jj) * rn_pfac * smask0(ji,jj) ! solid precipitation [kg/m2/s] + + ! --- evaporation --- ! + zevap(ji,jj) = emp(ji,jj) + tprecip(ji,jj) ! evaporation over ocean !LB: removed rn_efac here, correct??? + DO jl = 1, jpl + evap_ice (ji,jj,jl) = rn_efac * qla_ice (ji,jj,jl) * z1_rLsub ! sublimation + devap_ice(ji,jj,jl) = rn_efac * dqla_ice(ji,jj,jl) * z1_rLsub ! d(sublimation)/dT + ENDDO + END_2D - ! --- evaporation minus precipitation --- ! zsnw(:,:) = 0._wp - CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing - emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) - emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw - emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) - - ! --- heat flux associated with emp --- ! - qemp_oce(:,:) = - ( 1._wp - at_i_b(:,:) ) * zevap(:,:) * zcptn(:,:) & ! evap at sst - & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) & ! liquid precip at Tair - & + sprecip(:,:) * ( 1._wp - zsnw ) * ( zcptsnw (:,:) - rLfus ) ! solid precip at min(Tair,Tsnow) - qemp_ice(:,:) = sprecip(:,:) * zsnw * ( zcptsnw (:,:) - rLfus ) ! solid precip (only) - - ! --- total solar and non solar fluxes --- ! - qns_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) & - & + qemp_ice(:,:) + qemp_oce(:,:) - qsr_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) - - ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! - qprec_ice(:,:) = rhos * ( zcptsnw(:,:) - rLfus ) - - ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- - DO jl = 1, jpl - qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * rcpi * tmask(:,:,1) ) - ! ! But we do not have Tice => consider it at 0degC => evap=0 - END DO + CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw(:,:) ) ! snow distribution over ice after wind blowing + DO_2D( 0, 0, 0, 0 ) + ! --- evaporation minus precipitation --- ! + emp_oce(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * zevap(ji,jj) - ( tprecip(ji,jj) - sprecip(ji,jj) ) - sprecip(ji,jj) * (1._wp - zsnw(ji,jj) ) + emp_ice(ji,jj) = SUM( a_i_b(ji,jj,:) * evap_ice(ji,jj,:) ) - sprecip(ji,jj) * zsnw(ji,jj) + emp_tot(ji,jj) = emp_oce(ji,jj) + emp_ice(ji,jj) + + ! --- heat flux associated with emp --- ! + qemp_oce(ji,jj) = - ( 1._wp - at_i_b(ji,jj) ) * zevap(ji,jj) * zcptn(ji,jj) & ! evap at sst + & + ( tprecip(ji,jj) - sprecip(ji,jj) ) * zcptrain(ji,jj) & ! liquid precip at Tair + & + sprecip(ji,jj) * ( 1._wp - zsnw(ji,jj) ) * ( zcptsnw (ji,jj) - rLfus ) ! solid precip at min(Tair,Tsnow) + qemp_ice(ji,jj) = sprecip(ji,jj) * zsnw(ji,jj) * ( zcptsnw (ji,jj) - rLfus ) ! solid precip (only) + + ! --- total solar and non solar fluxes --- ! + qns_tot(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + SUM( a_i_b(ji,jj,:) * qns_ice(ji,jj,:) ) & + & + qemp_ice(ji,jj) + qemp_oce(ji,jj) + qsr_tot(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) + SUM( a_i_b(ji,jj,:) * qsr_ice(ji,jj,:) ) + + ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! + qprec_ice(ji,jj) = rhos * ( zcptsnw(ji,jj) - rLfus ) + + ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- + DO jl = 1, jpl + qevap_ice(ji,jj,jl) = 0._wp ! should be -evap_ice(ji,jj,jl)*( ( Tice - rt0 ) * rcpi * smask0(ji,jj) ) + ! ! But we do not have Tice => consider it at 0degC => evap=0 + ENDDO + END_2D ! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- ! IF( nn_qtrice == 0 ) THEN @@ -1247,9 +1257,11 @@ CONTAINS qtr_ice_top(:,:,:) = 0.3_wp * qsr_ice(:,:,:) ENDIF ! + CALL iom_put( 'snowpre', sprecip ) ! Snow precipitation + CALL iom_put( 'precip' , tprecip ) ! Total precipitation IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN - CALL iom_put( 'evap_ao_cea' , zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) - CALL iom_put( 'hflx_evap_cea', zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * tmask(:,:,1) * zcptn(:,:) ) ! heat flux from evap (cell average) + CALL iom_put( 'evap_ao_cea' , zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * smask0(:,:) ) ! ice-free oce evap (cell average) + CALL iom_put( 'hflx_evap_cea', zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * smask0(:,:) * zcptn(:,:) ) ! heat flux from evap (cell average) ENDIF IF( iom_use('rain') .OR. iom_use('rain_ao_cea') .OR. iom_use('hflx_rain_cea') ) THEN CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation @@ -1269,14 +1281,14 @@ CONTAINS & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) ENDIF IF( iom_use('subl_ai_cea') .OR. iom_use('hflx_subl_cea') ) THEN - CALL iom_put( 'subl_ai_cea' , SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) - CALL iom_put( 'hflx_subl_cea', SUM( a_i_b(:,:,:) * qevap_ice(:,:,:), dim=3 ) * tmask(:,:,1) ) ! Heat flux from sublimation (cell average) + CALL iom_put( 'subl_ai_cea' , SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) * smask0(:,:) ) ! Sublimation over sea-ice (cell average) + CALL iom_put( 'hflx_subl_cea', SUM( a_i_b(:,:,:) * qevap_ice(:,:,:), dim=3 ) * smask0(:,:) ) ! Heat flux from sublimation (cell average) ENDIF ! IF(sn_cfctl%l_prtctl) THEN - ALLOCATE(zmsk(jpi,jpj,jpl)) + ALLOCATE(zmsk(A2D(0),jpl)) DO jl = 1, jpl - zmsk(:,:,jl) = tmask(:,:,1) + zmsk(:,:,jl) = smask0(:,:) END DO CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice: qla_ice : ', mask1=zmsk, & & tab3d_2=z_qsb , clinfo2=' z_qsb : ' , mask2=zmsk, kdim=jpl) @@ -1289,7 +1301,7 @@ CONTAINS CALL prt_ctl(tab3d_1=ptsu , clinfo1=' blk_ice: ptsu : ', mask1=zmsk, & & tab3d_2=qns_ice , clinfo2=' qns_ice : ' , mask2=zmsk, kdim=jpl) CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice: tprecip : ', mask1=tmask, & - & tab2d_2=sprecip , clinfo2=' sprecip : ' , mask2=tmask ) + & tab2d_2=sprecip , clinfo2=' sprecip : ' , mask2=tmask ) DEALLOCATE(zmsk) ENDIF @@ -1303,7 +1315,9 @@ CONTAINS END SUBROUTINE blk_ice_2 - SUBROUTINE blk_ice_qcn( ld_virtual_itd, ptsu, ptb, phs, phi ) + SUBROUTINE blk_ice_qcn( ld_virtual_itd, ptb, phs, phi, & ! <<== in + & pqcn_ice, pqml_ice, & ! ==>> out + & pqns_ice, ptsu ) ! ==>> inout !!--------------------------------------------------------------------- !! *** ROUTINE blk_ice_qcn *** !! @@ -1318,12 +1332,15 @@ CONTAINS !! - qcn_ice : surface inner conduction flux (W/m2) !! !!--------------------------------------------------------------------- - LOGICAL , INTENT(in ) :: ld_virtual_itd ! single-category option - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptsu ! sea ice / snow surface temperature - REAL(wp), DIMENSION(:,:) , INTENT(in ) :: ptb ! sea ice base temperature - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phs ! snow thickness - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phi ! sea ice thickness - ! + LOGICAL , INTENT(in ) :: ld_virtual_itd ! single-category option + REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: ptb ! sea ice base temperature + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: phs ! snow thickness + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: phi ! sea ice thickness + REAL(wp), DIMENSION(A2D(0),jpl), INTENT( out) :: pqcn_ice + REAL(wp), DIMENSION(A2D(0),jpl), INTENT( out) :: pqml_ice + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pqns_ice + REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: ptsu ! sea ice / snow surface temperature + ! INTEGER , PARAMETER :: nit = 10 ! number of iterations REAL(wp), PARAMETER :: zepsilon = 0.1_wp ! characteristic thickness for enhanced conduction ! @@ -1333,7 +1350,7 @@ CONTAINS REAL(wp) :: zkeff_h, ztsu, ztsu0 ! REAL(wp) :: zqc, zqnet ! REAL(wp) :: zhe, zqa0 ! - REAL(wp), DIMENSION(jpi,jpj,jpl) :: zgfac ! enhanced conduction factor + REAL(wp), DIMENSION(A2D(0),jpl) :: zgfac ! enhanced conduction factor !!--------------------------------------------------------------------- ! -------------------------------------! @@ -1351,7 +1368,7 @@ CONTAINS zfac3 = 2._wp / zepsilon ! DO jl = 1, jpl - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac ! Effective thickness IF( zhe >= zfac2 ) zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor END_2D @@ -1366,13 +1383,13 @@ CONTAINS zfac = rcnd_i * rn_cnd_s ! DO jl = 1, jpl - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness & ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) ) ztsu = ptsu(ji,jj,jl) ! Store current iteration temperature ztsu0 = ptsu(ji,jj,jl) ! Store initial surface temperature - zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux + zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + pqns_ice(ji,jj,jl) ! Net initial atmospheric heat flux ! DO iter = 1, nit ! --- Iterative loop zqc = zkeff_h * ( ztsu - ptb(ji,jj) ) ! Conduction heat flux through snow-ice system (>0 downwards) @@ -1380,10 +1397,10 @@ CONTAINS ztsu = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h ) ! Temperature update END DO ! - ptsu (ji,jj,jl) = MIN( rt0, ztsu ) - qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) - qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) - qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) ) & + ptsu (ji,jj,jl) = MIN( rt0, ztsu ) + pqcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) + pqns_ice(ji,jj,jl) = pqns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) + pqml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + pqns_ice(ji,jj,jl) - pqcn_ice(ji,jj,jl) ) & & * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) ) ! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- ! diff --git a/src/OCE/SBC/sbcblk_algo_andreas.F90 b/src/OCE/SBC/sbcblk_algo_andreas.F90 index 5a2eb4113595c75c929953fceb95da6314a69ff3..7145a156fe42b3e658dcbea788db44783a43a7c3 100644 --- a/src/OCE/SBC/sbcblk_algo_andreas.F90 +++ b/src/OCE/SBC/sbcblk_algo_andreas.F90 @@ -85,34 +85,34 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: sst ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: ssq ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s] ! INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN ! INTEGER :: nbit, jit ! iterations... LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U !! - REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star - REAL(wp), DIMENSION(jpi,jpj) :: z0 ! roughness length (momentum) [m] - REAL(wp), DIMENSION(jpi,jpj) :: UN10 ! Neutral wind speed at zu [m/s] - REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu - REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 - REAL(wp), DIMENSION(jpi,jpj) :: RiB ! square root of Cd + REAL(wp), DIMENSION(A2D(0)) :: u_star, t_star, q_star + REAL(wp), DIMENSION(A2D(0)) :: z0 ! roughness length (momentum) [m] + REAL(wp), DIMENSION(A2D(0)) :: UN10 ! Neutral wind speed at zu [m/s] + REAL(wp), DIMENSION(A2D(0)) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(A2D(0)) :: RiB ! square root of Cd !! !!---------------------------------------------------------------------------------- nbit = nb_iter0 @@ -217,13 +217,13 @@ CONTAINS !! !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pun10 !: neutral-stability scalar wind speed at 10m (m/s) - REAL(wp), DIMENSION(jpi,jpj) :: u_star_andreas !: friction velocity [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pun10 !: neutral-stability scalar wind speed at 10m (m/s) + REAL(wp), DIMENSION(A2D(0)) :: u_star_andreas !: friction velocity [m/s] ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: za, zt, zw ! local scalars !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zw = pun10(ji,jj) za = zw - 8.271_wp zt = za + SQRT( 0.12_wp*za*za + 0.181_wp ) @@ -243,8 +243,8 @@ CONTAINS !! !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_m_andreas - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_m_andreas + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! REAL(wp), PARAMETER :: zam = 5._wp ! a_m (just below Eq.(9b) REAL(wp), PARAMETER :: zbm = zam/6.5_wp ! b_m (just below Eq.(9b) @@ -255,7 +255,7 @@ CONTAINS INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zx2, zx, zpsi_unst, zbbm, zpsi_stab, zstab ! local scalars !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zta = MIN( pzeta(ji,jj) , 15._wp ) !! Very stable conditions (L positif and big!) ! @@ -298,8 +298,8 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_h_andreas - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_h_andreas + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! REAL(wp), PARAMETER :: zah = 5._wp ! a_h (just below Eq.(9b) REAL(wp), PARAMETER :: zbh = 5._wp ! b_h (just below Eq.(9b) @@ -309,7 +309,7 @@ CONTAINS INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zz, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zta = MIN( pzeta(ji,jj) , 15._wp ) !! Very stable conditions (L positif and large!) ! diff --git a/src/OCE/SBC/sbcblk_algo_coare3p0.F90 b/src/OCE/SBC/sbcblk_algo_coare3p0.F90 index 2ad244fcb4d788a921e25c502cfd966d479db70f..cd3da3ebd6b5853f812570fb9d666c583ed28080 100644 --- a/src/OCE/SBC/sbcblk_algo_coare3p0.F90 +++ b/src/OCE/SBC/sbcblk_algo_coare3p0.F90 @@ -71,7 +71,7 @@ CONTAINS !!--------------------------------------------------------------------- IF( l_use_wl ) THEN ierr = 0 - ALLOCATE ( Tau_ac(jpi,jpj) , Qnt_ac(jpi,jpj), dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + ALLOCATE ( Tau_ac(A2D(0)) , Qnt_ac(A2D(0)), dT_wl(A2D(0)), Hz_wl(A2D(0)), STAT=ierr ) IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P0_INIT => allocation of Tau_ac, Qnt_ac, dT_wl & Hz_wl failed!' ) Tau_ac(:,:) = 0._wp Qnt_ac(:,:) = 0._wp @@ -80,7 +80,7 @@ CONTAINS ENDIF IF( l_use_cs ) THEN ierr = 0 - ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + ALLOCATE ( dT_cs(A2D(0)), STAT=ierr ) IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P0_INIT => allocation of dT_cs failed!' ) dT_cs(:,:) = -0.25_wp ! First guess of skin correction ENDIF @@ -151,44 +151,44 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - INTEGER, INTENT(in ) :: kt ! current time step - REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization - LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s] ! - INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN - REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] - REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] - REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pHz_wl ! [m] ! INTEGER :: nbit, jit LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U ! - REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star - REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu - REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air - REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t - REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu - REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 - REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + REAL(wp), DIMENSION(A2D(0)) :: u_star, t_star, q_star + REAL(wp), DIMENSION(A2D(0)) :: dt_zu, dq_zu + REAL(wp), DIMENSION(A2D(0)) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(A2D(0)) :: z0, z0t + REAL(wp), DIMENSION(A2D(0)) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(A2D(0)) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] ! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST @@ -201,7 +201,7 @@ CONTAINS IF( PRESENT(nb_iter) ) nbit = nb_iter l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision - IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(A2D(0)) ) !! Initializations for cool skin and warm layer: IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & @@ -211,7 +211,7 @@ CONTAINS & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) IF( l_use_cs .OR. l_use_wl ) THEN - ALLOCATE ( zsst(jpi,jpj) ) + ALLOCATE ( zsst(A2D(0)) ) zsst = T_s ! backing up the bulk SST IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s @@ -334,8 +334,8 @@ CONTAINS CALL CS_COARE( Qsw, ztmp1, u_star, zsst, ztmp2 ) ! ! Qnsol -> ztmp1 / Qlat -> ztmp2 - T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) - IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) + T_s(:,:) = zsst(:,:) + dT_cs(:,:)*smask0(:,:) + IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*smask0(:,:) q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) ENDIF @@ -347,8 +347,8 @@ CONTAINS CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) ) !! Updating T_s and q_s !!! - T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) - IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) + T_s(:,:) = zsst(:,:) + dT_wl(:,:)*smask0(:,:) + IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*smask0(:,:) q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) ENDIF @@ -392,13 +392,13 @@ CONTAINS !! !! Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p0 - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed + REAL(wp), DIMENSION(A2D(0)) :: charn_coare3p0 + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwnd ! wind speed ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zw, zgt10, zgt18 !!------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zw = pwnd(ji,jj) ! wind speed ! @@ -426,13 +426,13 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_m_coare + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zta = pzeta(ji,jj) ! @@ -474,13 +474,13 @@ CONTAINS !! Author: L. Brodeau, June 2016 / AeroBulk !! (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_h_coare + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab !!---------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zta = pzeta(ji,jj) ! diff --git a/src/OCE/SBC/sbcblk_algo_coare3p6.F90 b/src/OCE/SBC/sbcblk_algo_coare3p6.F90 index cb7fff12b99999e0c740d5d8a23393f8dcfec3e7..50f6800a0cd9b34f82ff23ae01ecbf999d654f39 100644 --- a/src/OCE/SBC/sbcblk_algo_coare3p6.F90 +++ b/src/OCE/SBC/sbcblk_algo_coare3p6.F90 @@ -61,7 +61,7 @@ CONTAINS !!--------------------------------------------------------------------- IF( l_use_wl ) THEN ierr = 0 - ALLOCATE ( Tau_ac(jpi,jpj) , Qnt_ac(jpi,jpj), dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + ALLOCATE ( Tau_ac(A2D(0)) , Qnt_ac(A2D(0)), dT_wl(A2D(0)), Hz_wl(A2D(0)), STAT=ierr ) IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P6_INIT => allocation of Tau_ac, Qnt_ac, dT_wl & Hz_wl failed!' ) Tau_ac(:,:) = 0._wp Qnt_ac(:,:) = 0._wp @@ -70,7 +70,7 @@ CONTAINS ENDIF IF( l_use_cs ) THEN ierr = 0 - ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + ALLOCATE ( dT_cs(A2D(0)), STAT=ierr ) IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P6_INIT => allocation of dT_cs failed!' ) dT_cs(:,:) = -0.25_wp ! First guess of skin correction ENDIF @@ -141,44 +141,44 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - INTEGER, INTENT(in ) :: kt ! current time step - REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization - LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s] ! - INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN - REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] - REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] - REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pHz_wl ! [m] ! INTEGER :: nbit, jit LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U ! - REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star - REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu - REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air - REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t - REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu - REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 - REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + REAL(wp), DIMENSION(A2D(0)) :: u_star, t_star, q_star + REAL(wp), DIMENSION(A2D(0)) :: dt_zu, dq_zu + REAL(wp), DIMENSION(A2D(0)) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(A2D(0)) :: z0, z0t + REAL(wp), DIMENSION(A2D(0)) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(A2D(0)) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] ! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST @@ -191,7 +191,7 @@ CONTAINS IF( PRESENT(nb_iter) ) nbit = nb_iter l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision - IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(A2D(0)) ) !! Initializations for cool skin and warm layer: IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & @@ -201,7 +201,7 @@ CONTAINS & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) IF( l_use_cs .OR. l_use_wl ) THEN - ALLOCATE ( zsst(jpi,jpj) ) + ALLOCATE ( zsst(A2D(0)) ) zsst = T_s ! backing up the bulk SST IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s @@ -324,8 +324,8 @@ CONTAINS CALL CS_COARE( Qsw, ztmp1, u_star, zsst, ztmp2 ) ! ! Qnsol -> ztmp1 / Qlat -> ztmp2 - T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) - IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) + T_s(:,:) = zsst(:,:) + dT_cs(:,:)*smask0(:,:) + IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*smask0(:,:) q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) ENDIF @@ -337,8 +337,8 @@ CONTAINS CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) ) !! Updating T_s and q_s !!! - T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) - IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) + T_s(:,:) = zsst(:,:) + dT_wl(:,:)*smask0(:,:) + IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*smask0(:,:) q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) ENDIF @@ -378,8 +378,8 @@ CONTAINS !! !! Author: L. Brodeau, July 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6 - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! neutral wind speed at 10m + REAL(wp), DIMENSION(A2D(0)) :: charn_coare3p6 + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwnd ! neutral wind speed at 10m ! REAL(wp), PARAMETER :: charn0_max = 0.028 !: value above which the Charnock parameter levels off for winds > 18 m/s !!------------------------------------------------------------------- @@ -395,10 +395,10 @@ CONTAINS !! !! Author: L. Brodeau, October 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6_wave - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! friction velocity [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwsh ! significant wave height [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwps ! phase speed of dominant waves [m/s] + REAL(wp), DIMENSION(A2D(0)) :: charn_coare3p6_wave + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus ! friction velocity [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwsh ! significant wave height [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwps ! phase speed of dominant waves [m/s] !!------------------------------------------------------------------- charn_coare3p6_wave = ( pwsh*0.2_wp*(pus/pwps)**2.2_wp ) * grav/(pus*pus) !! @@ -418,13 +418,13 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_m_coare + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zta = pzeta(ji,jj) ! @@ -466,13 +466,13 @@ CONTAINS !! Author: L. Brodeau, June 2016 / AeroBulk !! (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_h_coare + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab !!---------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zta = pzeta(ji,jj) ! diff --git a/src/OCE/SBC/sbcblk_algo_ecmwf.F90 b/src/OCE/SBC/sbcblk_algo_ecmwf.F90 index d86c997565a355c17a2eee34b0f6b1ab72c06b92..eb316c81a35d78dbbe837788e3d03a477cad8f03 100644 --- a/src/OCE/SBC/sbcblk_algo_ecmwf.F90 +++ b/src/OCE/SBC/sbcblk_algo_ecmwf.F90 @@ -69,14 +69,14 @@ CONTAINS !!--------------------------------------------------------------------- IF( l_use_wl ) THEN ierr = 0 - ALLOCATE ( dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + ALLOCATE ( dT_wl(A2D(0)), Hz_wl(A2D(0)), STAT=ierr ) IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_wl & Hz_wl failed!' ) dT_wl(:,:) = 0._wp Hz_wl(:,:) = rd0 ! (rd0, constant, = 3m is default for Zeng & Beljaars) ENDIF IF( l_use_cs ) THEN ierr = 0 - ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + ALLOCATE ( dT_cs(A2D(0)), STAT=ierr ) IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_cs failed!' ) dT_cs(:,:) = -0.25_wp ! First guess of skin correction ENDIF @@ -147,48 +147,48 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - INTEGER, INTENT(in ) :: kt ! current time step - REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization - LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s] ! - INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN - REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] - REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] - REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pHz_wl ! [m] ! INTEGER :: nbit, jit LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U ! - REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star - REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu - REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air - REAL(wp), DIMENSION(jpi,jpj) :: Linv !: 1/L (inverse of Monin Obukhov length... - REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t, z0q - REAL(wp), DIMENSION(jpi,jpj) :: zrhoa, zpre, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + REAL(wp), DIMENSION(A2D(0)) :: u_star, t_star, q_star + REAL(wp), DIMENSION(A2D(0)) :: dt_zu, dq_zu + REAL(wp), DIMENSION(A2D(0)) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(A2D(0)) :: Linv !: 1/L (inverse of Monin Obukhov length... + REAL(wp), DIMENSION(A2D(0)) :: z0, z0t, z0q + REAL(wp), DIMENSION(A2D(0)) :: zrhoa, zpre, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] ! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST ! - REAL(wp), DIMENSION(jpi,jpj) :: func_m, func_h - REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(A2D(0)) :: func_m, func_h + REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2 CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ecmwf@sbcblk_algo_ecmwf.F90' !!---------------------------------------------------------------------------------- IF( kt == nit000 ) CALL SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl) @@ -206,7 +206,7 @@ CONTAINS & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) IF( l_use_cs .OR. l_use_wl ) THEN - ALLOCATE ( zsst(jpi,jpj) ) + ALLOCATE ( zsst(A2D(0)) ) zsst = T_s ! backing up the bulk SST IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s @@ -360,8 +360,8 @@ CONTAINS CALL CS_ECMWF( Qsw, ztmp1, u_star, zsst ) ! Qnsol -> ztmp1 - T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) - IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) + T_s(:,:) = zsst(:,:) + dT_cs(:,:)*smask0(:,:) + IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*smask0(:,:) q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) ENDIF @@ -372,8 +372,8 @@ CONTAINS & ztmp1, ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp2 CALL WL_ECMWF( Qsw, ztmp1, u_star, zsst ) !! Updating T_s and q_s !!! - T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) ! - IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) + T_s(:,:) = zsst(:,:) + dT_wl(:,:)*smask0(:,:) ! + IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*smask0(:,:) q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) ENDIF @@ -413,14 +413,14 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ecmwf - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_m_ecmwf + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zx2, zx, ztmp, zpsi_unst, zpsi_stab, zstab, zc !!---------------------------------------------------------------------------------- zc = 5._wp/0.35_wp - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): @@ -454,15 +454,15 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ecmwf - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_h_ecmwf + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab, zc !!---------------------------------------------------------------------------------- zc = 5._wp/0.35_wp ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!): ! diff --git a/src/OCE/SBC/sbcblk_algo_ice_an05.F90 b/src/OCE/SBC/sbcblk_algo_ice_an05.F90 index 50ea20f6682af81c64258f1f549ac47700222717..36ed050eabd179a12ab59a318eefeccb6979fe21 100644 --- a/src/OCE/SBC/sbcblk_algo_ice_an05.F90 +++ b/src/OCE/SBC/sbcblk_algo_ice_an05.F90 @@ -79,26 +79,26 @@ CONTAINS !! !! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: Ts_i ! ice surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! spec. air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xUN10 ! Neutral wind at zu !!---------------------------------------------------------------------------------- REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp0, ztmp1, ztmp2 ! temporary stuff @@ -116,10 +116,10 @@ CONTAINS !! CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_an05@sbcblk_algo_ice_an05.f90' !!---------------------------------------------------------------------------------- - ALLOCATE ( Ubzu(jpi,jpj), u_star(jpi,jpj), t_star(jpi,jpj), q_star(jpi,jpj), & - & zeta_u(jpi,jpj), dt_zu(jpi,jpj), dq_zu(jpi,jpj), & - & znu_a(jpi,jpj), ztmp1(jpi,jpj), ztmp2(jpi,jpj), & - & z0(jpi,jpj), z0tq(jpi,jpj,2), ztmp0(jpi,jpj) ) + ALLOCATE ( Ubzu(A2D(0)), u_star(A2D(0)), t_star(A2D(0)), q_star(A2D(0)), & + & zeta_u(A2D(0)), dt_zu(A2D(0)), dq_zu(A2D(0)), & + & znu_a(A2D(0)), ztmp1(A2D(0)), ztmp2(A2D(0)), & + & z0(A2D(0)), z0tq(A2D(0),2), ztmp0(A2D(0)) ) lreturn_cdn = PRESENT(CdN) lreturn_chn = PRESENT(ChN) @@ -130,7 +130,7 @@ CONTAINS lreturn_UN10 = PRESENT(xUN10) l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) - IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(A2D(0)) ) !! Scalar wind speed cannot be below 0.2 m/s Ubzu = MAX( U_zu, wspd_thrshld_ice ) @@ -227,14 +227,14 @@ CONTAINS !! !! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: rough_leng_m ! roughness length over sea-ice [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] + REAL(wp), DIMENSION(A2D(0)) :: rough_leng_m ! roughness length over sea-ice [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus ! u* = friction velocity [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] !! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zus, zz !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zus = MAX( pus(ji,jj) , 1.E-9_wp ) zz = (zus - 0.18_wp) / 0.1_wp @@ -251,16 +251,16 @@ CONTAINS !! !! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj,2) :: rough_leng_tq ! temp.,hum. roughness lengthes over sea-ice [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 ! roughness length [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] + REAL(wp), DIMENSION(A2D(0),2) :: rough_leng_tq ! temp.,hum. roughness lengthes over sea-ice [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0 ! roughness length [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus ! u* = friction velocity [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] !! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zz0, zus, zre, zsmoot, ztrans, zrough REAL(wp) :: zb0, zb1, zb2, zlog, zlog2, zlog_z0s_on_z0 !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zz0 = pz0(ji,jj) zus = MAX( pus(ji,jj) , 1.E-9_wp ) zre = MAX( zus*zz0/pnua(ji,jj) , 0._wp ) ! Roughness Reynolds number @@ -315,13 +315,13 @@ CONTAINS !! !! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ice - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_m_ice + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! + DO_2D( 0, 0, 0, 0 ) ! zta = pzeta(ji,jj) ! ! Unstable stratification: @@ -360,13 +360,13 @@ CONTAINS !! !! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ice - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_h_ice + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! + DO_2D( 0, 0, 0, 0 ) ! zta = pzeta(ji,jj) ! ! Unstable stratification: diff --git a/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 b/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 index 87932e3966985a6ae8c676671104989e099c246f..0a9103f8a706baf1627109dde6d612425b193788 100644 --- a/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 +++ b/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 @@ -59,12 +59,12 @@ CONTAINS !! ** References : Lupkes et al. JGR 2012 (theory) !! !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU12 ! neutral FORM drag coefficient contribution over sea-ice - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided... - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc2 ! squared shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] + REAL(wp), DIMENSION(A2D(0)) :: CdN10_f_LU12 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided... + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0w ! roughness length over water [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pSc2 ! squared shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] !!---------------------------------------------------------------------- LOGICAL :: l_known_Sc2=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE. REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc2, zhf, zDi @@ -74,7 +74,7 @@ CONTAINS l_known_hf = PRESENT(phf) l_known_Di = PRESENT(pDi) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zfri = pfrice(ji,jj) zfrw = (1._wp - zfri) @@ -113,9 +113,9 @@ CONTAINS FUNCTION CdN_f_LU12_eq36( pzu, pfrice ) !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LU12_eq36 ! neutral FORM drag coefficient contribution over sea-ice - REAL(wp), INTENT(in) :: pzu ! reference height [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided... + REAL(wp), DIMENSION(A2D(0)) :: CdN_f_LU12_eq36 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), INTENT(in) :: pzu ! reference height [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided... !!---------------------------------------------------------------------- REAL(wp) :: ztmp, zrlog, zfri, zhf, zDi INTEGER :: ji, jj @@ -127,7 +127,7 @@ CONTAINS ztmp = 1._wp/rz0_w_0 zrlog = LOG(zhf*ztmp) / LOG(pzu*ztmp) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zfri = pfrice(ji,jj) CdN_f_LU12_eq36(ji,jj) = 0.5_wp* 0.3_wp * zrlog*zrlog * zhf/zDi * (1._wp - zfri)**rBeta_0 ! Eq.(35) & (36) !! 1/2 Ce @@ -167,8 +167,8 @@ CONTAINS !! Lupkes et al. GRL 2013 (application to GCM) !! !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU13 ! neutral FORM drag coefficient contribution over sea-ice - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b + REAL(wp), DIMENSION(A2D(0)) :: CdN10_f_LU13 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b !!---------------------------------------------------------------------- INTEGER :: ji, jj REAL(wp) :: zcoef @@ -178,7 +178,7 @@ CONTAINS !! We are not an AGCM, we are an OGCM!!! => we drop term "(1 - A)*Cd_w" !! => so we keep only the last rhs terms of Eq.(1) of Lupkes et al, 2013 that we divide by "A": !! (we multiply Cd_i_s and Cd_i_f by A later, when applying ocean-ice partitioning... - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) CdN10_f_LU13(ji,jj) = rCe_0 * pfrice(ji,jj)**(rMu_0 - 1._wp) * (1._wp - pfrice(ji,jj))**zcoef END_2D !! => seems okay for winter 100% sea-ice as second rhs term vanishes as pfrice == 1.... @@ -203,13 +203,13 @@ CONTAINS !! ** References : Lupkes & Gryanik (2015) !! !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15 ! neutral FORM drag coefficient contribution over sea-ice - REAL(wp), INTENT(in ) :: pzu ! reference height [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided... - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0i ! roughness length over ICE [m] (in LU12, it's over water ???) - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc2 ! squared shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] + REAL(wp), DIMENSION(A2D(0)) :: CdN_f_LG15 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), INTENT(in ) :: pzu ! reference height [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided... + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0i ! roughness length over ICE [m] (in LU12, it's over water ???) + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pSc2 ! squared shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] !!---------------------------------------------------------------------- LOGICAL :: l_known_Sc2=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE. REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc2, zhf, zDi @@ -219,7 +219,7 @@ CONTAINS l_known_hf = PRESENT(phf) l_known_Di = PRESENT(pDi) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zfri = pfrice(ji,jj) zfrw = (1._wp - zfri) @@ -270,15 +270,15 @@ CONTAINS !! ** References : Lupkes & Gryanik (2015) !! !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15_light ! neutral FORM drag coefficient contribution over sea-ice - REAL(wp), INTENT(in) :: pzu ! reference height [m] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m] + REAL(wp), DIMENSION(A2D(0)) :: CdN_f_LG15_light ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), INTENT(in) :: pzu ! reference height [m] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0w ! roughness length over water [m] !!---------------------------------------------------------------------- REAL(wp) :: ztmp, zrlog, zfri INTEGER :: ji, jj !!---------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zfri = pfrice(ji,jj) diff --git a/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 b/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 index 62ec01b8236d2735d600b354ea7bcd64d2025ac1..9c9302faa60317317f071f6b7238cb7b60457f5d 100644 --- a/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 +++ b/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 @@ -42,6 +42,8 @@ MODULE sbcblk_algo_ice_lg15 INTEGER , PARAMETER :: nbit = 8 ! number of itterations + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- CONTAINS @@ -92,27 +94,27 @@ CONTAINS !! !! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction) - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: Ts_i ! ice surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! spec. air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: frice ! sea-ice concentration (fraction) + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xUN10 ! Neutral wind at zu !!---------------------------------------------------------------------------------- REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp1, ztmp2 ! temporary stuff @@ -128,11 +130,11 @@ CONTAINS !! CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_lg15@sbcblk_algo_ice_lg15.f90' !!---------------------------------------------------------------------------------- - ALLOCATE ( Ubzu(jpi,jpj) ) - ALLOCATE ( ztmp1(jpi,jpj), ztmp2(jpi,jpj) ) - ALLOCATE ( dt_zu(jpi,jpj), dq_zu(jpi,jpj) ) - ALLOCATE ( zz0_s(jpi,jpj), zz0_f(jpi,jpj), RiB(jpi,jpj), & - & zCdN_s(jpi,jpj), zChN_s(jpi,jpj), zCdN_f(jpi,jpj), zChN_f(jpi,jpj) ) + ALLOCATE ( Ubzu(A2D(0)) ) + ALLOCATE ( ztmp1(A2D(0)), ztmp2(A2D(0)) ) + ALLOCATE ( dt_zu(A2D(0)), dq_zu(A2D(0)) ) + ALLOCATE ( zz0_s(A2D(0)), zz0_f(A2D(0)), RiB(A2D(0)), & + & zCdN_s(A2D(0)), zChN_s(A2D(0)), zCdN_f(A2D(0)), zChN_f(A2D(0)) ) lreturn_cdn = PRESENT(CdN) lreturn_chn = PRESENT(ChN) diff --git a/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 b/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 index d46534a362b0ad9a7486ee86d45a5e8cec34bf0f..10a4dbf60ff50a4931b0d7c0ae915330f17330ef 100644 --- a/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 +++ b/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 @@ -32,6 +32,8 @@ MODULE sbcblk_algo_ice_lu12 REAL(wp), PARAMETER :: rz0_i_s_0 = 0.69e-3_wp ! Eq.(43) of Lupkes & Gryanik (2015) [m] => to estimate CdN10 for skin drag! REAL(wp), PARAMETER :: rz0_i_f_0 = 4.54e-4_wp ! bottom p.562 MIZ [m] (LG15) + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- CONTAINS @@ -79,27 +81,27 @@ CONTAINS !! !! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction) - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] - REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: Ts_i ! ice surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! spec. air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: frice ! sea-ice concentration (fraction) + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) - REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xUN10 ! Neutral wind at zu !!---------------------------------------------------------------------------------- REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu, z0 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu @@ -109,8 +111,8 @@ CONTAINS !! CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_lu12@sbcblk_algo_ice_lu12.f90' !!---------------------------------------------------------------------------------- - ALLOCATE ( Ubzu(jpi,jpj) ) - ALLOCATE ( dt_zu(jpi,jpj), dq_zu(jpi,jpj), z0(jpi,jpj) ) + ALLOCATE ( Ubzu(A2D(0)) ) + ALLOCATE ( dt_zu(A2D(0)), dq_zu(A2D(0)), z0(A2D(0)) ) lreturn_cdn = PRESENT(CdN) lreturn_chn = PRESENT(ChN) diff --git a/src/OCE/SBC/sbcblk_algo_ncar.F90 b/src/OCE/SBC/sbcblk_algo_ncar.F90 index bb520dbf07993c584ac4e9f50c3187e18a711a05..4e218454e57d5c49520cfacc72269b82f82947f3 100644 --- a/src/OCE/SBC/sbcblk_algo_ncar.F90 +++ b/src/OCE/SBC/sbcblk_algo_ncar.F90 @@ -79,32 +79,32 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: sst ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: ssq ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s] ! - INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN - REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN ! INTEGER :: nbit, jit ! iterations... LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U ! - REAL(wp), DIMENSION(jpi,jpj) :: zCdN, zCeN, zChN ! 10m neutral latent/sensible coefficient - REAL(wp), DIMENSION(jpi,jpj) :: zsqrt_Cd, zsqrt_CdN ! root square of Cd and Cd_neutral - REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu - REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(A2D(0)) :: zCdN, zCeN, zChN ! 10m neutral latent/sensible coefficient + REAL(wp), DIMENSION(A2D(0)) :: zsqrt_Cd, zsqrt_CdN ! root square of Cd and Cd_neutral + REAL(wp), DIMENSION(A2D(0)) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2 !!---------------------------------------------------------------------------------- nbit = nb_iter0 IF( PRESENT(nb_iter) ) nbit = nb_iter @@ -119,7 +119,7 @@ CONTAINS !! Neutral coefficients at 10m: IF( ln_cdgw ) THEN ! wave drag case - cdn_wave(:,:) = cdn_wave(:,:) + rsmall * ( 1._wp - tmask(:,:,1) ) + cdn_wave(:,:) = cdn_wave(:,:) + rsmall * ( 1._wp - smask0(:,:) ) zCdN (:,:) = cdn_wave(:,:) ELSE zCdN = cd_n10_ncar( Ubzu ) @@ -231,14 +231,14 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pw10 ! scalar wind speed at 10m (m/s) - REAL(wp), DIMENSION(jpi,jpj) :: cd_n10_ncar + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pw10 ! scalar wind speed at 10m (m/s) + REAL(wp), DIMENSION(A2D(0)) :: cd_n10_ncar ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zgt33, zw, zw6 ! local scalars !!---------------------------------------------------------------------------------- ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zw = pw10(ji,jj) zw6 = zw*zw*zw @@ -264,9 +264,9 @@ CONTAINS !! Origin: Large & Yeager 2008, Eq. (9) and (12) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: ch_n10_ncar - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pstab ! stable ABL => 1 / unstable ABL => 0 + REAL(wp), DIMENSION(A2D(0)) :: ch_n10_ncar + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pstab ! stable ABL => 1 / unstable ABL => 0 !!---------------------------------------------------------------------------------- IF( ANY(pstab < -0.00001) .OR. ANY(pstab > 1.00001) ) THEN PRINT *, 'ERROR: ch_n10_ncar@mod_blk_ncar.f90: pstab =' @@ -283,8 +283,8 @@ CONTAINS !! Estimate of the neutral heat transfer coefficient at 10m !! !! Origin: Large & Yeager 2008, Eq. (9) and (13) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: ce_n10_ncar - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) + REAL(wp), DIMENSION(A2D(0)) :: ce_n10_ncar + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) !!---------------------------------------------------------------------------------- ce_n10_ncar = MAX( 1.e-3_wp * ( 34.6_wp * psqrtcdn10 ) , Cx_min ) ! @@ -301,13 +301,13 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ncar - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_m_ncar + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zx2, zx, zpsi_unst, zpsi_stab, zstab ! local scalars !!---------------------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zta = pzeta(ji,jj) ! zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 @@ -339,14 +339,14 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ncar - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(A2D(0)) :: psi_h_ncar + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars !!---------------------------------------------------------------------------------- ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ! zta = pzeta(ji,jj) ! diff --git a/src/OCE/SBC/sbcblk_skin_coare.F90 b/src/OCE/SBC/sbcblk_skin_coare.F90 index 42720bd939e3dfb1dd45ed1545495120efe50732..ddd6af7f2d0f7ad4f70a3679e7ed8e455bd6cb2e 100644 --- a/src/OCE/SBC/sbcblk_skin_coare.F90 +++ b/src/OCE/SBC/sbcblk_skin_coare.F90 @@ -79,16 +79,16 @@ CONTAINS !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] !! *pQlat* surface latent heat flux [K] !!------------------------------------------------------------------ - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQlat ! latent heat flux [W/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pSST ! bulk SST [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQlat ! latent heat flux [W/m^2] !!--------------------------------------------------------------------- INTEGER :: ji, jj, jc REAL(wp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus !!--------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, ! ! => we DO not miss a lot assuming 0 solar flux absorbed in the tiny layer of thicknes zdlt... @@ -129,11 +129,11 @@ CONTAINS !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] !! *iwait* if /= 0 then wait before updating accumulated fluxes, we are within a converging itteration loop... !!--------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTau ! wind stress [N/m^2] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] - INTEGER , INTENT(in) :: iwait ! if /= 0 then wait before updating accumulated fluxes + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTau ! wind stress [N/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] + INTEGER , INTENT(in) :: iwait ! if /= 0 then wait before updating accumulated fluxes !! INTEGER :: ji,jj ! @@ -155,7 +155,7 @@ CONTAINS ztime = REAL(nsec_day,wp)/(24._wp*3600._wp) ! time of current time step since 00:00 for current day (UTC) -> ztime = 0 -> 00:00 / ztime = 0.5 -> 12:00 ... - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) l_exit = .FALSE. l_destroy_wl = .FALSE. diff --git a/src/OCE/SBC/sbcblk_skin_ecmwf.F90 b/src/OCE/SBC/sbcblk_skin_ecmwf.F90 index 0f4cf8d5d37f7fa8cfa6bbefed0b68e822c7382f..e38437168acc696a864ce3c681c677ae731cd891 100644 --- a/src/OCE/SBC/sbcblk_skin_ecmwf.F90 +++ b/src/OCE/SBC/sbcblk_skin_ecmwf.F90 @@ -87,15 +87,15 @@ CONTAINS !! *pustar* friction velocity u* [m/s] !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] !!------------------------------------------------------------------ - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pSST ! bulk SST [K] !!--------------------------------------------------------------------- INTEGER :: ji, jj, jc REAL(wp) :: zQabs, zdlt, zfr, zalfa, zus !!--------------------------------------------------------------------- - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, ! ! => we DO not miss a lot assuming 0 solar flux absorbed in the tiny layer of thicknes zdlt... @@ -147,12 +147,12 @@ CONTAINS !! *pustar* friction velocity u* [m/s] !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] !!------------------------------------------------------------------ - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity [m/s] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pustar ! friction velocity [m/s] + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] !! - REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pustk ! surface Stokes velocity [m/s] + REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pustk ! surface Stokes velocity [m/s] ! INTEGER :: ji, jj, jc ! @@ -173,7 +173,7 @@ CONTAINS l_pustk_known = .FALSE. IF( PRESENT(pustk) ) l_pustk_known = .TRUE. - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zHwl = Hz_wl(ji,jj) ! first guess for warm-layer depth (and unique..., less advanced than COARE3p6 !) ! it is = rd0 (3m) in default Zeng & Beljaars case... diff --git a/src/OCE/SBC/sbcclo.F90 b/src/OCE/SBC/sbcclo.F90 index ba956f5e32dfa77dfea9106ee2855e2b2659d716..1f48db25bb7ce34f03f2a7f901daeb8c1faf7db2 100644 --- a/src/OCE/SBC/sbcclo.F90 +++ b/src/OCE/SBC/sbcclo.F90 @@ -44,6 +44,8 @@ MODULE sbcclo ! INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: mcsgrpg, mcsgrpr, mcsgrpe !: closed sea group for glo, rnf and emp ! + !! * Substitutions +# include "do_loop_substitute.h90" CONTAINS ! !!---------------------------------------------------------------------- @@ -120,8 +122,8 @@ MODULE sbcclo CALL iom_put('qclosea',zqcs) ! ! 3. update emp and qns - emp(:,:) = emp(:,:) + zwcs(:,:) - qns(:,:) = qns(:,:) + zqcs(:,:) + emp(A2D(0)) = emp(A2D(0)) + zwcs(A2D(0)) + qns(:,:) = qns(:,:) + zqcs(A2D(0)) ! END SUBROUTINE sbc_clo ! @@ -289,7 +291,7 @@ MODULE sbcclo !! 1. Work out net freshwater over the closed sea from EMP - RNF. !! Work out net heat associated with the correction (needed for conservation) !! (PM: should we consider used delayed glob sum ?) - zcsfw = glob_sum( 'closea', e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * imsk_src(:,:) ) + zcsfw = glob_sum( 'closea', e1e2t(A2D(0)) * ( emp(A2D(0))-rnf(A2D(0)) ) * imsk_src(A2D(0)) ) ! !! 2. Deal with runoff special case (net evaporation spread globally) !! and compute trg mask diff --git a/src/OCE/SBC/sbccpl.F90 b/src/OCE/SBC/sbccpl.F90 index 64d77b504b6cfc0cc427e731d8f0f8d9af4c07e7..dcb56415de93d7904673f84d4e0575f151da81f3 100644 --- a/src/OCE/SBC/sbccpl.F90 +++ b/src/OCE/SBC/sbccpl.F90 @@ -65,6 +65,7 @@ MODULE sbccpl PUBLIC sbc_cpl_ice_flx ! routine called by icestp.F90 PUBLIC sbc_cpl_alloc ! routine called in sbcice_cice.F90 + !! received fields are only in the interior (without halos) INTEGER, PARAMETER :: jpr_otx1 = 1 ! 3 atmosphere-ocean stress components on grid 1 INTEGER, PARAMETER :: jpr_oty1 = 2 ! INTEGER, PARAMETER :: jpr_otz1 = 3 ! @@ -131,7 +132,8 @@ MODULE sbccpl INTEGER, PARAMETER :: jpr_qtrice = 63 ! Transmitted solar thru sea-ice INTEGER, PARAMETER :: jprcv = 63 ! total number of fields received - + + !! sent fields are only in the interior (without halos) INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere INTEGER, PARAMETER :: jps_toce = 2 ! ocean temperature INTEGER, PARAMETER :: jps_tice = 3 ! ice temperature @@ -238,12 +240,12 @@ CONTAINS !!---------------------------------------------------------------------- ierr(:) = 0 ! - ALLOCATE( alb_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) ) + ALLOCATE( alb_oce_mix(A2D(0)), nrcvinfo(jprcv), STAT=ierr(1) ) #if ! defined key_si3 && ! defined key_cice ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) #endif - ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) + ALLOCATE( xcplmask(A2D(0),0:nn_cplmodel) , STAT=ierr(3) ) ! IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(4) ) @@ -270,7 +272,7 @@ CONTAINS ! INTEGER :: jn ! dummy loop index INTEGER :: ios, inum ! Local integer - REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos + REAL(wp), DIMENSION(A2D(0)) :: zacs, zaos !! NAMELIST/namsbc_cpl/ nn_cplmodel , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux, & & sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & @@ -739,19 +741,19 @@ CONTAINS ! Allocate all parts of frcv used for received fields ! ! =================================================== ! DO jn = 1, jprcv - IF( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) ) + IF( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(A2D(0),srcv(jn)%nct) ) END DO ! Allocate taum part of frcv which is used even when not received as coupling field - IF( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) ) + IF( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(A2D(0),srcv(jpr_taum)%nct) ) ! Allocate w10m part of frcv which is used even when not received as coupling field - IF( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(jpi,jpj,srcv(jpr_w10m)%nct) ) + IF( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(A2D(0),srcv(jpr_w10m)%nct) ) ! Allocate jpr_otx1 part of frcv which is used even when not received as coupling field - IF( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(jpi,jpj,srcv(jpr_otx1)%nct) ) - IF( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(jpi,jpj,srcv(jpr_oty1)%nct) ) + IF( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(A2D(0),srcv(jpr_otx1)%nct) ) + IF( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(A2D(0),srcv(jpr_oty1)%nct) ) ! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE. IF( k_ice /= 0 ) THEN - IF( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(jpi,jpj,srcv(jpr_itx1)%nct) ) - IF( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(jpi,jpj,srcv(jpr_ity1)%nct) ) + IF( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(A2D(0),srcv(jpr_itx1)%nct) ) + IF( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(A2D(0),srcv(jpr_ity1)%nct) ) ENDIF ! ================================ ! @@ -1051,15 +1053,14 @@ CONTAINS IF(ln_usecplmask) THEN xcplmask(:,:,:) = 0. CALL iom_open( 'cplmask', inum ) - CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:jpi,1:jpj,1:nn_cplmodel), & - & kstart = (/ mig(1,nn_hls),mjg(1,nn_hls),1 /), kcount = (/ jpi,jpj,nn_cplmodel /) ) + CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(:,:,1:nn_cplmodel), & + & kstart = (/ mig(Nis0,0),mjg(Njs0,0),1 /), kcount = (/ Ni_0,Nj_0,nn_cplmodel /) ) CALL iom_close( inum ) ELSE xcplmask(:,:,:) = 1. ENDIF xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 ) ! - ! END SUBROUTINE sbc_cpl_init @@ -1124,7 +1125,8 @@ CONTAINS REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient REAL(wp) :: zzx, zzy ! temporary variables REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0) - REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra + REAL(wp), DIMENSION(A2D(0)) :: ztx, zty, zmsk, zemp + REAL(wp), DIMENSION(A2D(0)) :: zqns, zqsr, zcloud_fra !!---------------------------------------------------------------------- ! IF( kt == nit000 ) THEN @@ -1139,7 +1141,7 @@ CONTAINS ENDIF ENDIF ! - IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) + IF( ln_mixcpl ) zmsk (:,:) = 1. - xcplmask (:,:,0) ! ! ! ======================================================= ! ! ! Receive all the atmos. fields (including ice information) @@ -1191,9 +1193,11 @@ CONTAINS IF( .NOT. srcv(jpr_taum)%laction ) THEN ! compute wind stress module from its components if not received ! => need to be done only when otx1 was changed IF( llnewtx ) THEN - zzx = frcv(jpr_otx1)%z3(ji,jj,1) - zzy = frcv(jpr_oty1)%z3(ji,jj,1) - frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) + DO_2D( 0, 0, 0, 0 ) + zzx = frcv(jpr_otx1)%z3(ji,jj,1) + zzy = frcv(jpr_oty1)%z3(ji,jj,1) + frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) + END_2D llnewtau = .TRUE. ELSE llnewtau = .FALSE. @@ -1202,7 +1206,7 @@ CONTAINS llnewtau = nrcvinfo(jpr_taum) == OASIS_Rcv ! Stress module can be negative when received (interpolation problem) IF( llnewtau ) THEN - frcv(jpr_taum)%z3(:,:,1) = MAX( 0._wp, frcv(jpr_taum)%z3(:,:,1) ) + frcv(jpr_taum)%z3(A2D(0),1) = MAX( 0._wp, frcv(jpr_taum)%z3(A2D(0),1) ) ENDIF ENDIF ! @@ -1213,7 +1217,7 @@ CONTAINS ! => need to be done only when taumod was changed IF( llnewtau ) THEN zcoef = 1. / ( zrhoa * zcdrag ) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) END_2D ENDIF @@ -1221,7 +1225,7 @@ CONTAINS !!$ ! ! ========================= ! !!$ SELECT CASE( TRIM( sn_rcv_clouds%cldes ) ) ! cloud fraction ! !!$ ! ! ========================= ! -!!$ cloud_fra(:,:) = frcv(jpr_clfra)*z3(:,:,1) +!!$ cloud_fra(:,:) = frcv(jpr_clfra)*z3(A2D(0),1) !!$ END SELECT !!$ zcloud_fra(:,:) = pp_cldf ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. @@ -1259,13 +1263,14 @@ CONTAINS ! ! Mean Sea Level Pressure ! (taum) ! ! ========================= ! IF( srcv(jpr_mslp)%laction ) THEN ! UKMO SHELF effect of atmospheric pressure on SSH - IF( kt /= nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) !* Swap of ssh_ib fields + IF( kt /= nit000 ) ssh_ibb(A2D(0)) = ssh_ib(A2D(0)) !* Swap of ssh_ib fields r1_grau = 1.e0 / (grav * rho0) !* constant for optimization - ssh_ib(:,:) = - ( frcv(jpr_mslp)%z3(:,:,1) - rpref ) * r1_grau ! equivalent ssh (inverse barometer) - apr (:,:) = frcv(jpr_mslp)%z3(:,:,1) !atmospheric pressure + ssh_ib(A2D(0)) = - ( frcv(jpr_mslp)%z3(:,:,1) - rpref ) * r1_grau ! equivalent ssh (inverse barometer) + apr (A2D(0)) = frcv(jpr_mslp)%z3(:,:,1) !atmospheric pressure - IF( kt == nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) ! correct this later (read from restart if possible) + IF( kt == nit000 ) ssh_ibb(A2D(0)) = ssh_ib(A2D(0)) ! correct this later (read from restart if possible) + CALL lbc_lnk( 'sbccpl', ssh_ib, 'T', 1.0_wp, ssh_ibb, 'T', 1.0_wp ) ENDIF ! IF( ln_sdw ) THEN ! Stokes Drift correction activated @@ -1361,30 +1366,33 @@ CONTAINS ! ! SST ! ! ! ================== ! IF( srcv(jpr_toce)%laction ) THEN ! received by sas in case of opa <-> sas coupling - sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1) + sst_m(A2D(0)) = frcv(jpr_toce)%z3(:,:,1) IF( srcv(jpr_soce)%laction .AND. l_useCT ) THEN ! make sure that sst_m is the potential temperature - sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) ) + sst_m(A2D(0)) = eos_pt_from_ct( sst_m(A2D(0)), sss_m(A2D(0)) ) ENDIF + CALL iom_put( 'sst_m', sst_m ) ENDIF ! ! ================== ! ! ! SSH ! ! ! ================== ! IF( srcv(jpr_ssh )%laction ) THEN ! received by sas in case of opa <-> sas coupling - ssh_m(:,:) = frcv(jpr_ssh )%z3(:,:,1) + ssh_m(A2D(0)) = frcv(jpr_ssh )%z3(:,:,1) CALL iom_put( 'ssh_m', ssh_m ) ENDIF ! ! ================== ! ! ! surface currents ! ! ! ================== ! IF( srcv(jpr_ocx1)%laction ) THEN ! received by sas in case of opa <-> sas coupling - ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) - uu(:,:,1,Kbb) = ssu_m(:,:) ! will be used in icestp in the call of ice_forcing_tau + ssu_m(A2D(0)) = frcv(jpr_ocx1)%z3(:,:,1) + CALL lbc_lnk( 'sbccpl', ssu_m, 'U', -1.0_wp ) + uu(:,:,1,Kbb) = ssu_m(:,:) ! will be used in icestp in the call of ice_update_tau uu(:,:,1,Kmm) = ssu_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling CALL iom_put( 'ssu_m', ssu_m ) ENDIF IF( srcv(jpr_ocy1)%laction ) THEN - ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) - vv(:,:,1,Kbb) = ssv_m(:,:) ! will be used in icestp in the call of ice_forcing_tau + ssv_m(A2D(0)) = frcv(jpr_ocy1)%z3(:,:,1) + CALL lbc_lnk( 'sbccpl', ssv_m, 'V', -1.0_wp ) + vv(:,:,1,Kbb) = ssv_m(:,:) ! will be used in icestp in the call of ice_update_tau vv(:,:,1,Kmm) = ssv_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling CALL iom_put( 'ssv_m', ssv_m ) ENDIF @@ -1392,14 +1400,14 @@ CONTAINS ! ! first T level thickness ! ! ! ======================== ! IF( srcv(jpr_e3t1st )%laction ) THEN ! received by sas in case of opa <-> sas coupling - e3t_m(:,:) = frcv(jpr_e3t1st )%z3(:,:,1) - CALL iom_put( 'e3t_m', e3t_m(:,:) ) + e3t_m(A2D(0)) = frcv(jpr_e3t1st )%z3(:,:,1) + CALL iom_put( 'e3t_m', e3t_m ) ENDIF ! ! ================================ ! ! ! fraction of solar net radiation ! ! ! ================================ ! IF( srcv(jpr_fraqsr)%laction ) THEN ! received by sas in case of opa <-> sas coupling - frq_m(:,:) = frcv(jpr_fraqsr)%z3(:,:,1) + frq_m(A2D(0)) = frcv(jpr_fraqsr)%z3(:,:,1) CALL iom_put( 'frq_m', frq_m ) ENDIF @@ -1422,21 +1430,21 @@ CONTAINS ENDIF ! ! ! runoffs and calving (added in emp) - IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) + IF( srcv(jpr_rnf)%laction ) rnf(A2D(0)) = frcv(jpr_rnf)%z3(:,:,1) IF( srcv(jpr_cal)%laction ) zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1) IF( srcv(jpr_icb)%laction ) THEN - fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) - rnf(:,:) = rnf(:,:) + fwficb(:,:) ! iceberg added to runfofs + fwficb(A2D(0)) = frcv(jpr_icb)%z3(:,:,1) + rnf (A2D(0)) = rnf(A2D(0)) + fwficb(A2D(0)) ! iceberg added to runfofs ENDIF ! ! ice shelf fwf IF( srcv(jpr_isf)%laction ) THEN - fwfisf_oasis(:,:) = frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf to the ocean ( > 0 = melting ) + fwfisf_oasis(A2D(0)) = frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf to the ocean ( > 0 = melting ) END IF - IF( ln_mixcpl ) THEN ; emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) - ELSE ; emp(:,:) = zemp(:,:) + IF( ln_mixcpl ) THEN ; emp(A2D(0)) = emp(A2D(0)) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) + ELSE ; emp(A2D(0)) = zemp(:,:) ENDIF ! ! ! non solar heat flux over the ocean (qns) @@ -1446,7 +1454,7 @@ CONTAINS ENDIF ! update qns over the free ocean with: IF( nn_components /= jp_iam_oce ) THEN - zqns(:,:) = zqns(:,:) - zemp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST) + zqns(:,:) = zqns(:,:) - zemp(:,:) * sst_m(A2D(0)) * rcp ! remove heat content due to mass flux (assumed to be at SST) IF( srcv(jpr_snow )%laction ) THEN zqns(:,:) = zqns(:,:) - frcv(jpr_snow)%z3(:,:,1) * rLfus ! energy for melting solid precipitation over the free ocean ENDIF @@ -1509,13 +1517,13 @@ CONTAINS !! !! ** Action : return ptau_i, ptau_j, the stress over the ice !!---------------------------------------------------------------------- - REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2] - REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_tauj ! at T-point + REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: p_taui ! i- & j-components of atmos-ice stress [N/m2] + REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: p_tauj ! at T-point !! INTEGER :: ji, jj ! dummy loop indices INTEGER :: itx ! index of taux over ice - REAL(wp) :: zztmp1, zztmp2 - REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty + REAL(wp) :: zztmp1, zztmp2 + REAL(wp), DIMENSION(A2D(0)) :: ztx, zty !!---------------------------------------------------------------------- ! #if defined key_si3 || defined key_cice @@ -1622,22 +1630,23 @@ CONTAINS !! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice !! sprecip solid precipitation over the ocean !!---------------------------------------------------------------------- - INTEGER, INTENT(in) :: kt ! ocean model time step index (only for a_i_last_couple) - REAL(wp), INTENT(in) , DIMENSION(:,:) :: picefr ! ice fraction [0 to 1] - ! !! ! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling - REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo - REAL(wp), INTENT(in) , DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] - REAL(wp), INTENT(inout), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office - REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m] - REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phi ! ice thickness [m] + INTEGER, INTENT(in) :: kt ! ocean model time step index (only for a_i_last_couple) + REAL(wp), INTENT(in) , DIMENSION(A2D(0)) :: picefr ! ice fraction [0 to 1] + ! !! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling + REAL(wp), INTENT(in) , DIMENSION(A2D(0),jpl), OPTIONAL :: palbi ! all skies ice albedo + REAL(wp), INTENT(in) , DIMENSION(A2D(0) ), OPTIONAL :: psst ! sea surface temperature [Celsius] + REAL(wp), INTENT(inout), DIMENSION(A2D(0),jpl), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office + REAL(wp), INTENT(in) , DIMENSION(A2D(0),jpl), OPTIONAL :: phs ! snow depth [m] + REAL(wp), INTENT(in) , DIMENSION(A2D(0),jpl), OPTIONAL :: phi ! ice thickness [m] ! INTEGER :: ji, jj, jl ! dummy loop index - REAL(wp), DIMENSION(jpi,jpj) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw - REAL(wp), DIMENSION(jpi,jpj) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice - REAL(wp), DIMENSION(jpi,jpj) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice - REAL(wp), DIMENSION(jpi,jpj) :: zevap_ice_total - REAL(wp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu - REAL(wp), DIMENSION(jpi,jpj) :: ztri + REAL(wp), DIMENSION(A2D(0)) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw + REAL(wp), DIMENSION(A2D(0)) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice + REAL(wp), DIMENSION(A2D(0)) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice + REAL(wp), DIMENSION(A2D(0)) :: zevap_ice_total + REAL(wp), DIMENSION(A2D(0)) :: ztri + REAL(wp), DIMENSION(A2D(0),jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top + REAL(wp), DIMENSION(A2D(0),jpl) :: ztsu !!---------------------------------------------------------------------- ! #if defined key_si3 || defined key_cice @@ -1651,7 +1660,7 @@ CONTAINS ! IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) ziceld(:,:) = 1._wp - picefr(:,:) - zcptn (:,:) = rcp * sst_m(:,:) + zcptn (:,:) = rcp * sst_m(A2D(0)) ! ! ! ========================= ! ! ! freshwater budget ! (emp_tot) @@ -1663,9 +1672,9 @@ CONTAINS ! ! sublimation - solid precipitation (cell average) (emp_ice) SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp - zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here - ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here - zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) + zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here + ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here + zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * picefr(:,:) @@ -1679,15 +1688,17 @@ CONTAINS ! --- evaporation over ice (kg/m2/s) --- ! IF( ln_scale_ice_flux ) THEN ! typically met-office requirements IF( sn_rcv_emp%clcat == 'yes' ) THEN - WHERE( a_i(:,:,:) > 1.e-10 ) ; zevap_ice(:,:,:) = frcv(jpr_ievp)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) - ELSEWHERE ; zevap_ice(:,:,:) = 0._wp + WHERE( a_i(A2D(0),:) > 1.e-10 ) ; zevap_ice(:,:,:) = frcv(jpr_ievp)%z3(:,:,:) * & + & a_i_last_couple(A2D(0),:) / a_i(A2D(0),:) + ELSEWHERE ; zevap_ice(:,:,:) = 0._wp END WHERE - WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) - ELSEWHERE ; zevap_ice_total(:,:) = 0._wp + WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) / picefr(:,:) + ELSEWHERE ; zevap_ice_total(:,:) = 0._wp END WHERE ELSE - WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) * SUM( a_i_last_couple, dim=3 ) / picefr(:,:) - ELSEWHERE ; zevap_ice(:,:,1) = 0._wp + WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) * & + & SUM( a_i_last_couple(A2D(0),:), dim=3 ) / picefr(:,:) + ELSEWHERE ; zevap_ice(:,:,1) = 0._wp END WHERE zevap_ice_total(:,:) = zevap_ice(:,:,1) DO jl = 2, jpl @@ -1697,7 +1708,7 @@ CONTAINS ELSE IF( sn_rcv_emp%clcat == 'yes' ) THEN zevap_ice(:,:,1:jpl) = frcv(jpr_ievp)%z3(:,:,1:jpl) - WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) + WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) / picefr(:,:) ELSEWHERE ; zevap_ice_total(:,:) = 0._wp END WHERE ELSE @@ -1730,18 +1741,18 @@ CONTAINS ! --- Continental fluxes --- ! IF( srcv(jpr_rnf)%laction ) THEN ! runoffs (included in emp later on) - rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) + rnf(A2D(0)) = frcv(jpr_rnf)%z3(:,:,1) ENDIF IF( srcv(jpr_cal)%laction ) THEN ! calving (put in emp_tot and emp_oce) zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) ENDIF IF( srcv(jpr_icb)%laction ) THEN ! iceberg added to runoffs - fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) - rnf(:,:) = rnf(:,:) + fwficb(:,:) + fwficb(A2D(0)) = frcv(jpr_icb)%z3(:,:,1) + rnf (A2D(0)) = rnf(A2D(0)) + fwficb(A2D(0)) ENDIF IF( srcv(jpr_isf)%laction ) THEN ! iceshelf (fwfisf > 0 mean melting) - fwfisf_oasis(:,:) = frcv(jpr_isf)%z3(:,:,1) + fwfisf_oasis(A2D(0)) = frcv(jpr_isf)%z3(:,:,1) ENDIF IF( ln_mixcpl ) THEN @@ -1796,17 +1807,17 @@ CONTAINS !!$ ENDIF ! ! outputs - IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1) ) ! calving - IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1) ) ! icebergs + IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(A2D(0),1) ) ! calving + IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(A2D(0),1) ) ! icebergs IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) IF( iom_use('rain_ao_cea') ) CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * ziceld(:,:) ) ! liquid precipitation over ocean (cell average) - IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , zevap_ice_total(:,:) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) + IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , zevap_ice_total(:,:) * picefr(:,:) * smask0(:,:) ) ! Sublimation over sea-ice (cell average) IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) & - & - zevap_ice_total(:,:) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) + & - zevap_ice_total(:,:) * picefr(:,:) ) * smask0(:,:) ) ! ice-free oce evap (cell average) ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf !! IF( srcv(jpr_rnf)%laction ) CALL iom_put( 'runoffs' , rnf(:,:) * tmask(:,:,1) ) ! runoff !! IF( srcv(jpr_isf)%laction ) CALL iom_put( 'iceshelf_cea', fwfisf(:,:) * tmask(:,:,1) ) ! iceshelf @@ -1816,9 +1827,9 @@ CONTAINS ! ! ========================= ! CASE( 'coupled' ) IF( ln_scale_ice_flux ) THEN - WHERE( a_i(:,:,:) > 1.e-10_wp ) - qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) - qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) + WHERE( a_i(A2D(0),:) > 1.e-10_wp ) + qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i_last_couple(A2D(0),:) / a_i(A2D(0),:) + qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i_last_couple(A2D(0),:) / a_i(A2D(0),:) ELSEWHERE qml_ice(:,:,:) = 0.0_wp qcn_ice(:,:,:) = 0.0_wp @@ -1841,7 +1852,7 @@ CONTAINS ENDIF ! Calculate the total non solar heat flux. The ocean only non solar heat flux (zqns_oce) will be recalculated after this CASE ! statement to be consistent with other coupling methods even though .zqns_oce = frcv(jpr_qnsoce)%z3(:,:,1) - zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) + SUM( zqns_ice(:,:,:) * a_i(:,:,:), dim=3 ) + zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) + SUM( zqns_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) CASE( 'conservative' ) ! the required fields are directly provided zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) IF( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN @@ -1855,7 +1866,7 @@ CONTAINS zqns_tot(:,:) = ziceld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) IF( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN DO jl=1,jpl - zqns_tot(:,: ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl) + zqns_tot(:,: ) = zqns_tot(:,:) + a_i(A2D(0),jl) * frcv(jpr_qnsice)%z3(:,:,jl) zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) ENDDO ELSE @@ -1884,21 +1895,22 @@ CONTAINS ! ! --- calving (removed from qns_tot) --- ! IF( srcv(jpr_cal)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * rLfus ! remove latent heat of calving - ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean + ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean ! --- iceberg (removed from qns_tot) --- ! IF( srcv(jpr_icb)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * rLfus ! remove latent heat of iceberg melting ! --- non solar flux over ocean --- ! ! note: ziceld cannot be = 0 since we limit the ice concentration to amax zqns_oce = 0._wp - WHERE( ziceld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / ziceld(:,:) + WHERE( ziceld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i(A2D(0),:) * zqns_ice(:,:,:), dim=3 ) ) / ziceld(:,:) ! Heat content per unit mass of snow (J/kg) - WHERE( SUM( a_i, dim=3 ) > 1.e-10 ) ; zcptsnw(:,:) = rcpi * SUM( (tn_ice - rt0) * a_i, dim=3 ) / SUM( a_i, dim=3 ) - ELSEWHERE ; zcptsnw(:,:) = zcptn(:,:) + WHERE( SUM( a_i(A2D(0),:), dim=3 ) > 1.e-10 ) ; zcptsnw(:,:) = rcpi * SUM( (tn_ice(:,:,:) - rt0) * a_i(A2D(0),:), dim=3 ) & + & / SUM( a_i(A2D(0),:), dim=3 ) + ELSEWHERE ; zcptsnw(:,:) = zcptn(:,:) ENDWHERE ! Heat content per unit mass of rain (J/kg) - zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * ziceld(:,:) ) + zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(A2D(0),:), dim=3 ) + sst_m(A2D(0)) * ziceld(:,:) ) ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! zqprec_ice(:,:) = rhos * ( zcptsnw(:,:) - rLfus ) @@ -1969,7 +1981,7 @@ CONTAINS & CALL iom_put('hflx_rain_cea' , ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) IF ( iom_use('hflx_evap_cea') ) & ! heat flux from evap (cell average) & CALL iom_put('hflx_evap_cea' , ( frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:) ) & - & * zcptn(:,:) * tmask(:,:,1) ) + & * zcptn(:,:) * smask0(:,:) ) IF ( iom_use('hflx_prec_cea') ) & ! heat flux from all precip (cell avg) & CALL iom_put('hflx_prec_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) & & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) @@ -1980,7 +1992,7 @@ CONTAINS IF ( iom_use('hflx_snow_ai_cea') ) & ! heat flux from snow (over ice) & CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * zsnw(:,:) ) IF( iom_use('hflx_subl_cea') ) & ! heat flux from sublimation - & CALL iom_put('hflx_subl_cea' , SUM( qevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) * tmask(:,:,1) ) + & CALL iom_put('hflx_subl_cea' , SUM( qevap_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) * smask0(:,:) ) ! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp. ! ! ! ========================= ! @@ -2028,7 +2040,7 @@ CONTAINS zqsr_tot(:,: ) = ziceld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) IF( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN DO jl = 1, jpl - zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl) + zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(A2D(0),jl) * frcv(jpr_qsrice)%z3(:,:,jl) zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) END DO ELSE @@ -2045,14 +2057,14 @@ CONTAINS IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN DO jl = 1, jpl zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:,jl) * ( 1.- palbi(:,:,jl) ) & - & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & - & + palbi (:,:,jl) * picefr(:,:) ) ) + & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & + & + palbi (:,:,jl) * picefr(:,:) ) ) END DO ELSE DO jl = 1, jpl zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:, 1) * ( 1.- palbi(:,:,jl) ) & - & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & - & + palbi (:,:,jl) * picefr(:,:) ) ) + & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & + & + palbi (:,:,jl) * picefr(:,:) ) ) END DO ENDIF CASE( 'none' ) ! Not available as for now: needs additional coding @@ -2060,7 +2072,7 @@ CONTAINS CALL ctl_stop('STOP', 'sbccpl/sbc_cpl_ice_flx: some fields are not defined. Change sn_rcv_qsr value in namelist namsbc_cpl') END SELECT IF( ln_dm2dc .AND. ln_cpl ) THEN ! modify qsr to include the diurnal cycle - zqsr_tot(:,: ) = sbc_dcy( zqsr_tot(:,: ) ) + zqsr_tot(:,:) = sbc_dcy( zqsr_tot(:,:) ) DO jl = 1, jpl zqsr_ice(:,:,jl) = sbc_dcy( zqsr_ice(:,:,jl) ) END DO @@ -2102,8 +2114,8 @@ CONTAINS ! ! ===> here we receive the qtr_ice_top array from the coupler CASE ('coupled') IF (ln_scale_ice_flux) THEN - WHERE( a_i(:,:,:) > 1.e-10_wp ) - zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) + WHERE( a_i(A2D(0),:) > 1.e-10_wp ) + zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:) * a_i_last_couple(A2D(0),:) / a_i(A2D(0),:) ELSEWHERE zqtr_ice_top(:,:,:) = 0.0_wp ENDWHERE @@ -2113,7 +2125,7 @@ CONTAINS ! Add retrieved transmitted solar radiation onto the ice and total solar radiation zqsr_ice(:,:,:) = zqsr_ice(:,:,:) + zqtr_ice_top(:,:,:) - zqsr_tot(:,:) = zqsr_tot(:,:) + SUM( zqtr_ice_top(:,:,:) * a_i(:,:,:), dim=3 ) + zqsr_tot(:,:) = zqsr_tot(:,:) + SUM( zqtr_ice_top(:,:,:) * a_i(A2D(0),:), dim=3 ) ! if we are not getting this data from the coupler then assume zero (fully opaque ice) CASE ('none') @@ -2123,7 +2135,7 @@ CONTAINS ENDIF IF( ln_mixcpl ) THEN - qsr_tot(:,:) = qsr(:,:) * ziceld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk + qsr_tot(:,:) = qsr(:,:) * ziceld(:,:) + SUM( qsr_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) ! total flux from blk qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) + zqsr_tot(:,:) * zmsk(:,:) DO jl = 1, jpl qsr_ice (:,:,jl) = qsr_ice (:,:,jl) * xcplmask(:,:,0) + zqsr_ice (:,:,jl) * zmsk(:,:) @@ -2138,7 +2150,7 @@ CONTAINS ! --- solar flux over ocean --- ! ! note: ziceld cannot be = 0 since we limit the ice concentration to amax zqsr_oce = 0._wp - WHERE( ziceld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / ziceld(:,:) + WHERE( ziceld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i(A2D(0),:) * zqsr_ice(:,:,:), dim=3 ) ) / ziceld(:,:) IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:) ELSE ; qsr_oce(:,:) = zqsr_oce(:,:) ; ENDIF @@ -2183,25 +2195,26 @@ CONTAINS INTEGER :: ji, jj, jl ! dummy loop indices INTEGER :: isec, info ! local integer REAL(wp) :: zumax, zvmax - REAL(wp), DIMENSION(jpi,jpj) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 - REAL(wp), DIMENSION(jpi,jpj,jpl) :: ztmp3, ztmp4 + REAL(wp), DIMENSION(A2D(0)) :: zat_i, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 + REAL(wp), DIMENSION(A2D(0),jpl) :: ztmp3, ztmp4 !!---------------------------------------------------------------------- ! isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges info = OASIS_idle - zfr_l(:,:) = 1.- fr_i(:,:) + zfr_l(:,:) = 1.- fr_i(A2D(0)) + zat_i(:,:) = SUM( a_i(A2D(0),:), dim=3 ) ! ! ------------------------- ! ! ! Surface temperature ! in Kelvin ! ! ------------------------- ! IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN IF( nn_components == jp_iam_oce ) THEN - ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part + ztmp1(:,:) = ts(A2D(0),1,jp_tem,Kmm) ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part ELSE ! we must send the surface potential temperature - IF( l_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem,Kmm), ts(:,:,1,jp_sal,Kmm) ) - ELSE ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) + IF( l_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( ts(A2D(0),1,jp_tem,Kmm), ts(A2D(0),1,jp_sal,Kmm) ) + ELSE ; ztmp1(:,:) = ts(A2D(0),1,jp_tem,Kmm) ENDIF ! SELECT CASE( sn_snd_temp%cldes) @@ -2211,8 +2224,8 @@ CONTAINS CASE( 'yes' ) ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) CASE( 'no' ) - WHERE( SUM( a_i, dim=3 ) /= 0. ) - ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) + WHERE( zat_i(:,:) /= 0. ) + ztmp3(:,:,1) = SUM( tn_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) / zat_i(:,:) ELSEWHERE ztmp3(:,:,1) = rt0 END WHERE @@ -2221,36 +2234,36 @@ CONTAINS CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) SELECT CASE( sn_snd_temp%clcat ) CASE( 'yes' ) - ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl) CASE( 'no' ) ztmp3(:,:,:) = 0.0 DO jl=1,jpl - ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) + ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(A2D(0),jl) ENDDO CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) END SELECT - CASE( 'oce and weighted ice') ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) + rt0 + CASE( 'oce and weighted ice') ; ztmp1(:,:) = ts(A2D(0),1,jp_tem,Kmm) + rt0 SELECT CASE( sn_snd_temp%clcat ) CASE( 'yes' ) - ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl) CASE( 'no' ) ztmp3(:,:,:) = 0.0 DO jl=1,jpl - ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) + ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(A2D(0),jl) ENDDO CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) END SELECT CASE( 'mixed oce-ice' ) ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) DO jl=1,jpl - ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) + ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(A2D(0),jl) ENDDO CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) END SELECT ENDIF - IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info ) IF( ssnd(jps_tice)%laction ) CALL cpl_snd( jps_tice, isec, ztmp3, info ) - IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info ) ENDIF ! ! ! ------------------------- ! @@ -2261,7 +2274,7 @@ CONTAINS IF( ssnd(jps_ttilyr)%laction) THEN SELECT CASE( sn_snd_ttilyr%cldes) CASE ('weighted ice') - ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl) CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ttilyr%cldes' ) END SELECT IF( ssnd(jps_ttilyr)%laction ) CALL cpl_snd( jps_ttilyr, isec, ztmp3, info ) @@ -2277,8 +2290,8 @@ CONTAINS CASE( 'yes' ) ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) CASE( 'no' ) - WHERE( SUM( a_i, dim=3 ) /= 0. ) - ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) + WHERE( zat_i(:,:) /= 0. ) + ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(A2D(0),1:jpl), dim=3 ) / zat_i(:,:) ELSEWHERE ztmp1(:,:) = alb_oce_mix(:,:) END WHERE @@ -2287,10 +2300,10 @@ CONTAINS CASE( 'weighted ice' ) ; SELECT CASE( sn_snd_alb%clcat ) CASE( 'yes' ) - ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl) CASE( 'no' ) - WHERE( fr_i (:,:) > 0. ) - ztmp1(:,:) = SUM ( alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) + WHERE( fr_i (A2D(0)) > 0. ) + ztmp1(:,:) = SUM ( alb_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl), dim=3 ) ELSEWHERE ztmp1(:,:) = 0. END WHERE @@ -2303,16 +2316,16 @@ CONTAINS CASE( 'yes' ) CALL cpl_snd( jps_albice, isec, ztmp3, info ) !-> MV this has never been checked in coupled mode CASE( 'no' ) - CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info ) END SELECT ENDIF IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean ztmp1(:,:) = alb_oce_mix(:,:) * zfr_l(:,:) DO jl = 1, jpl - ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl) + ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(A2D(0),jl) END DO - CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info ) ENDIF ! ! ------------------------- ! ! ! Ice fraction & Thickness ! @@ -2320,8 +2333,8 @@ CONTAINS ! Send ice fraction field to atmosphere IF( ssnd(jps_fice)%laction ) THEN SELECT CASE( sn_snd_thick%clcat ) - CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl) - CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: ) + CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(A2D(0),1:jpl) + CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(A2D(0) ) CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) END SELECT CALL cpl_snd( jps_fice, isec, ztmp3, info ) @@ -2341,8 +2354,8 @@ CONTAINS IF( ssnd(jps_fice1)%laction ) THEN SELECT CASE( sn_snd_thick1%clcat ) - CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl) - CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: ) + CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(A2D(0),1:jpl) + CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(A2D(0) ) CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick1%clcat' ) END SELECT CALL cpl_snd( jps_fice1, isec, ztmp3, info ) @@ -2350,7 +2363,7 @@ CONTAINS ! Send ice fraction field to OCE (sent by SAS in SAS-OCE coupling) IF( ssnd(jps_fice2)%laction ) THEN - ztmp3(:,:,1) = fr_i(:,:) + ztmp3(:,:,1) = fr_i(A2D(0)) IF( ssnd(jps_fice2)%laction ) CALL cpl_snd( jps_fice2, isec, ztmp3, info ) ENDIF @@ -2361,25 +2374,25 @@ CONTAINS CASE( 'weighted ice and snow' ) SELECT CASE( sn_snd_thick%clcat ) CASE( 'yes' ) - ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) * a_i(:,:,1:jpl) - ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) * a_i(:,:,1:jpl) + ztmp3(:,:,1:jpl) = h_i(A2D(0),1:jpl) * a_i(A2D(0),1:jpl) + ztmp4(:,:,1:jpl) = h_s(A2D(0),1:jpl) * a_i(A2D(0),1:jpl) CASE( 'no' ) ztmp3(:,:,:) = 0.0 ; ztmp4(:,:,:) = 0.0 DO jl=1,jpl - ztmp3(:,:,1) = ztmp3(:,:,1) + h_i(:,:,jl) * a_i(:,:,jl) - ztmp4(:,:,1) = ztmp4(:,:,1) + h_s(:,:,jl) * a_i(:,:,jl) + ztmp3(:,:,1) = ztmp3(:,:,1) + h_i(A2D(0),jl) * a_i(A2D(0),jl) + ztmp4(:,:,1) = ztmp4(:,:,1) + h_s(A2D(0),jl) * a_i(A2D(0),jl) ENDDO CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) END SELECT CASE( 'ice and snow' ) SELECT CASE( sn_snd_thick%clcat ) CASE( 'yes' ) - ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) - ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) + ztmp3(:,:,1:jpl) = h_i(A2D(0),1:jpl) + ztmp4(:,:,1:jpl) = h_s(A2D(0),1:jpl) CASE( 'no' ) WHERE( SUM( a_i, dim=3 ) /= 0. ) - ztmp3(:,:,1) = SUM( h_i * a_i, dim=3 ) / SUM( a_i, dim=3 ) - ztmp4(:,:,1) = SUM( h_s * a_i, dim=3 ) / SUM( a_i, dim=3 ) + ztmp3(:,:,1) = SUM( h_i(A2D(0),:) * a_i(A2D(0),:), dim=3 ) / zat_i(:,:) + ztmp4(:,:,1) = SUM( h_s(A2D(0),:) * a_i(A2D(0),:), dim=3 ) / zat_i(:,:) ELSEWHERE ztmp3(:,:,1) = 0. ztmp4(:,:,1) = 0. @@ -2403,13 +2416,13 @@ CONTAINS SELECT CASE( sn_snd_mpnd%clcat ) CASE( 'yes' ) ztmp3(:,:,1:jpl) = a_ip_eff(:,:,1:jpl) - ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl) + ztmp4(:,:,1:jpl) = h_ip(A2D(0),1:jpl) CASE( 'no' ) ztmp3(:,:,:) = 0.0 ztmp4(:,:,:) = 0.0 DO jl=1,jpl ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) - ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) + ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(A2D(0),jpl) ENDDO CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' ) END SELECT @@ -2428,11 +2441,11 @@ CONTAINS CASE( 'weighted ice' ) SELECT CASE( sn_snd_cond%clcat ) CASE( 'yes' ) - ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl) CASE( 'no' ) ztmp3(:,:,:) = 0.0 DO jl=1,jpl - ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(:,:,jl) + ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(A2D(0),jl) ENDDO CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%clcat' ) END SELECT @@ -2448,8 +2461,8 @@ CONTAINS ! ! CO2 flux from PISCES ! ! ! ------------------------- ! IF( ssnd(jps_co2)%laction .AND. l_co2cpl ) THEN - ztmp1(:,:) = oce_co2(:,:) * 1000. ! conversion in molC/m2/s - CALL cpl_snd( jps_co2, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ) , info ) + ztmp1(:,:) = oce_co2(A2D(0)) * 1000. ! conversion in molC/m2/s + CALL cpl_snd( jps_co2, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ) , info ) ENDIF ! ! ! ------------------------- ! @@ -2465,8 +2478,8 @@ CONTAINS ! i-1 i i !!clem: make a new variable at T-point to replace uu and vv => uuT and vvT for instance IF( nn_components == jp_iam_oce ) THEN - zotx1(:,:) = uu(:,:,1,Kmm) - zoty1(:,:) = vv(:,:,1,Kmm) + zotx1(:,:) = uu(A2D(0),1,Kmm) + zoty1(:,:) = vv(A2D(0),1,Kmm) !!clem : should be demi sum, no? Or uuT and vvT ELSE SELECT CASE( TRIM( sn_snd_crt%cldes ) ) @@ -2482,7 +2495,7 @@ CONTAINS zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) END_2D - CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) +!!$ CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T DO_2D( 0, 0, 0, 0 ) zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & @@ -2491,7 +2504,7 @@ CONTAINS & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) END_2D END SELECT - CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) +!!$ CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) ! ENDIF ! @@ -2523,13 +2536,13 @@ CONTAINS ENDIF ENDIF ! - IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid - IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid - IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid + IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/Ni_0,Nj_0,1/) ), info ) ! ocean x current 1st grid + IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/Ni_0,Nj_0,1/) ), info ) ! ocean y current 1st grid + IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/Ni_0,Nj_0,1/) ), info ) ! ocean z current 1st grid ! - IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid - IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid - IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid + IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/Ni_0,Nj_0,1/) ), info ) ! ice x current 1st grid + IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/Ni_0,Nj_0,1/) ), info ) ! ice y current 1st grid + IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/Ni_0,Nj_0,1/) ), info ) ! ice z current 1st grid ! ENDIF ! @@ -2559,7 +2572,7 @@ CONTAINS zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) END_2D - CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) +!!$ CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T DO_2D( 0, 0, 0, 0 ) zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & @@ -2568,7 +2581,7 @@ CONTAINS & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) END_2D END SELECT - CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) +!!$ CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) ! ! IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components @@ -2598,13 +2611,13 @@ CONTAINS ! ENDIF ! ENDIF ! - IF( ssnd(jps_ocxw)%laction ) CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid - IF( ssnd(jps_ocyw)%laction ) CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid + IF( ssnd(jps_ocxw)%laction ) CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/Ni_0,Nj_0,1/) ), info ) ! ocean x current 1st grid + IF( ssnd(jps_ocyw)%laction ) CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/Ni_0,Nj_0,1/) ), info ) ! ocean y current 1st grid ! ENDIF ! IF( ssnd(jps_ficet)%laction ) THEN - CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i, (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i(A2D(0)), (/Ni_0,Nj_0,1/) ), info ) ENDIF ! ! ------------------------- ! ! ! Water levels to waves ! @@ -2612,14 +2625,14 @@ CONTAINS IF( ssnd(jps_wlev)%laction ) THEN IF( ln_apr_dyn ) THEN IF( kt /= nit000 ) THEN - ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ztmp1(:,:) = ssh(A2D(0),Kbb) - 0.5 * ( ssh_ib(A2D(0)) + ssh_ibb(A2D(0)) ) ELSE - ztmp1(:,:) = ssh(:,:,Kbb) + ztmp1(:,:) = ssh(A2D(0),Kbb) ENDIF ELSE - ztmp1(:,:) = ssh(:,:,Kmm) + ztmp1(:,:) = ssh(A2D(0),Kmm) ENDIF - CALL cpl_snd( jps_wlev , isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_wlev , isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info ) ENDIF ! ! Fields sent by OCE to SAS when doing OCE<->SAS coupling @@ -2627,44 +2640,44 @@ CONTAINS IF( ssnd(jps_ssh )%laction ) THEN ! ! removed inverse barometer ssh when Patm ! forcing is used (for sea-ice dynamics) - IF( ln_apr_dyn ) THEN ; ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) - ELSE ; ztmp1(:,:) = ssh(:,:,Kmm) + IF( ln_apr_dyn ) THEN ; ztmp1(:,:) = ssh(A2D(0),Kbb) - 0.5 * ( ssh_ib(A2D(0)) + ssh_ibb(A2D(0)) ) + ELSE ; ztmp1(:,:) = ssh(A2D(0),Kmm) ENDIF - CALL cpl_snd( jps_ssh , isec, RESHAPE ( ztmp1 , (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_ssh , isec, RESHAPE ( ztmp1 , (/Ni_0,Nj_0,1/) ), info ) ENDIF ! ! SSS IF( ssnd(jps_soce )%laction ) THEN - CALL cpl_snd( jps_soce , isec, RESHAPE ( ts(:,:,1,jp_sal,Kmm), (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_soce , isec, RESHAPE ( ts(A2D(0),1,jp_sal,Kmm), (/Ni_0,Nj_0,1/) ), info ) ENDIF ! ! first T level thickness IF( ssnd(jps_e3t1st )%laction ) THEN - CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( e3t(:,:,1,Kmm) , (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( e3t(Nis0:Nie0,Njs0:Nje0,1,Kmm) , (/Ni_0,Nj_0,1/) ), info ) ENDIF ! ! Qsr fraction IF( ssnd(jps_fraqsr)%laction ) THEN - CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(:,:) , (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(A2D(0)) , (/Ni_0,Nj_0,1/) ), info ) ENDIF ! ! Fields sent by SAS to OCE when OASIS coupling ! ! Solar heat flux - IF( ssnd(jps_qsroce)%laction ) CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info ) - IF( ssnd(jps_qnsoce)%laction ) CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info ) - IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info ) - IF( ssnd(jps_sflx )%laction ) CALL cpl_snd( jps_sflx , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info ) - IF( ssnd(jps_otx1 )%laction ) CALL cpl_snd( jps_otx1 , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info ) - IF( ssnd(jps_oty1 )%laction ) CALL cpl_snd( jps_oty1 , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info ) - IF( ssnd(jps_rnf )%laction ) CALL cpl_snd( jps_rnf , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info ) - IF( ssnd(jps_taum )%laction ) CALL cpl_snd( jps_taum , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_qsroce)%laction ) CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr (:,:) , (/Ni_0,Nj_0,1/) ), info ) + IF( ssnd(jps_qnsoce)%laction ) CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns (:,:) , (/Ni_0,Nj_0,1/) ), info ) + IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, RESHAPE ( emp (A2D(0)), (/Ni_0,Nj_0,1/) ), info ) + IF( ssnd(jps_sflx )%laction ) CALL cpl_snd( jps_sflx , isec, RESHAPE ( sfx (:,:) , (/Ni_0,Nj_0,1/) ), info ) + IF( ssnd(jps_otx1 )%laction ) CALL cpl_snd( jps_otx1 , isec, RESHAPE ( utau(A2D(0)), (/Ni_0,Nj_0,1/) ), info ) + IF( ssnd(jps_oty1 )%laction ) CALL cpl_snd( jps_oty1 , isec, RESHAPE ( vtau(A2D(0)), (/Ni_0,Nj_0,1/) ), info ) + IF( ssnd(jps_rnf )%laction ) CALL cpl_snd( jps_rnf , isec, RESHAPE ( rnf (A2D(0)), (/Ni_0,Nj_0,1/) ), info ) + IF( ssnd(jps_taum )%laction ) CALL cpl_snd( jps_taum , isec, RESHAPE ( taum(:,:) , (/Ni_0,Nj_0,1/) ), info ) #if defined key_si3 ! ! ------------------------- ! ! ! Sea surface freezing temp ! ! ! ------------------------- ! ! needed by Met Office - CALL eos_fzp(ts(:,:,1,jp_sal,Kmm), sstfrz) + CALL eos_fzp(ts(A2D(0),1,jp_sal,Kmm), sstfrz) ztmp1(:,:) = sstfrz(:,:) + rt0 - IF( ssnd(jps_sstfrz)%laction ) CALL cpl_snd( jps_sstfrz, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info) + IF( ssnd(jps_sstfrz)%laction ) CALL cpl_snd( jps_sstfrz, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info) #endif ! END SUBROUTINE sbc_cpl_snd diff --git a/src/OCE/SBC/sbcdcy.F90 b/src/OCE/SBC/sbcdcy.F90 index a6ccd03321f0f73ef86af9e943cbcfbf03513ab4..5ccd7ec71b85dc87adbc38976692badd07c73b6e 100644 --- a/src/OCE/SBC/sbcdcy.F90 +++ b/src/OCE/SBC/sbcdcy.F90 @@ -49,8 +49,8 @@ CONTAINS !!---------------------------------------------------------------------- !! *** FUNCTION sbc_dcy_alloc *** !!---------------------------------------------------------------------- - ALLOCATE( raa (jpi,jpj) , rbb (jpi,jpj) , rcc (jpi,jpj) , rab (jpi,jpj) , & - & rtmd(jpi,jpj) , rdawn_dcy(jpi,jpj) , rdusk_dcy(jpi,jpj) , rscal(jpi,jpj) , STAT=sbc_dcy_alloc ) + ALLOCATE( raa (A2D(0)) , rbb (A2D(0)) , rcc (A2D(0)) , rab (A2D(0)) , & + & rtmd(A2D(0)) , rdawn_dcy(A2D(0)) , rdusk_dcy(A2D(0)) , rscal(A2D(0)) , STAT=sbc_dcy_alloc ) ! CALL mpp_sum ( 'sbcdcy', sbc_dcy_alloc ) IF( sbc_dcy_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_dcy_alloc: failed to allocate arrays' ) @@ -71,12 +71,12 @@ CONTAINS !! Impact of resolving the diurnal cycle in an ocean--atmosphere GCM. !! Part 1: a diurnally forced OGCM. Climate Dynamics 29:6, 575-590. !!---------------------------------------------------------------------- - LOGICAL , OPTIONAL , INTENT(in) :: l_mask ! use the routine for night mask computation - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqsrin ! input daily QSR flux - REAL(wp), DIMENSION(jpi,jpj) :: zqsrout ! output QSR flux with diurnal cycle + LOGICAL , OPTIONAL , INTENT(in) :: l_mask ! use the routine for night mask computation + REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqsrin ! input daily QSR flux + REAL(wp), DIMENSION(A2D(0)) :: zqsrout ! output QSR flux with diurnal cycle !! INTEGER :: ji, jj ! dummy loop indices - INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask + INTEGER, DIMENSION(A2D(0)) :: imask_night ! night mask REAL(wp) :: zlo, zup, zlousd, zupusd REAL(wp) :: ztmp, ztmp1, ztmp2 REAL(wp) :: ztmpm, ztmpm1, ztmpm2 @@ -100,16 +100,16 @@ CONTAINS ! Setting parameters for each new day: CALL sbc_dcy_param() - !CALL iom_put( "rdusk_dcy", rdusk_dcy(:,:)*tmask(:,:,1) ) !LB - !CALL iom_put( "rdawn_dcy", rdawn_dcy(:,:)*tmask(:,:,1) ) !LB - !CALL iom_put( "rscal_dcy", rscal(:,:)*tmask(:,:,1) ) !LB + !CALL iom_put( "rdusk_dcy", rdusk_dcy(:,:)*smask0(:,:) ) !LB + !CALL iom_put( "rdawn_dcy", rdawn_dcy(:,:)*smask0(:,:) ) !LB + !CALL iom_put( "rscal_dcy", rscal(:,:)*smask0(:,:) ) !LB ! 3. update qsr with the diurnal cycle ! ------------------------------------ imask_night(:,:) = 0 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ztmpm = 0._wp IF( ABS(rab(ji,jj)) < 1. ) THEN ! day duration is less than 24h ! @@ -161,7 +161,7 @@ CONTAINS SUBROUTINE sbc_dcy_param( ) !! INTEGER :: ji, jj ! dummy loop indices - !INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask + !INTEGER, DIMENSION(A2D(0)) :: imask_night ! night mask REAL(wp) :: zdsws, zdecrad, ztx, zsin, zcos REAL(wp) :: ztmp, ztest !---------------------------statement functions------------------------ @@ -192,7 +192,7 @@ CONTAINS ! Compute A and B needed to compute the time integral of the diurnal cycle zsin = SIN( zdecrad ) ; zcos = COS( zdecrad ) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) ztmp = rad * gphit(ji,jj) raa(ji,jj) = SIN( ztmp ) * zsin rbb(ji,jj) = COS( ztmp ) * zcos @@ -201,7 +201,7 @@ CONTAINS ! rab to test if the day time is equal to 0, less than 24h of full day rab(:,:) = -raa(:,:) / rbb(:,:) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h ! When is it night? ztx = 1._wp/(2._wp*rpi) * (ACOS(rab(ji,jj)) - rcc(ji,jj)) @@ -225,7 +225,7 @@ CONTAINS ! S* = the inverse of the time integral of the diurnal cycle from dawn to dusk ! Avoid possible infinite scaling factor, associated with very short daylight ! periods, by ignoring periods less than 1/1000th of a day (ticket #1040) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h rscal(ji,jj) = 0.0_wp IF( rdawn_dcy(ji,jj) < rdusk_dcy(ji,jj) ) THEN ! day time in one part diff --git a/src/OCE/SBC/sbcflx.F90 b/src/OCE/SBC/sbcflx.F90 index 7607f8e24a2e6fd59993d8765a4e53b1dd1c4fe8..b5e94d0e4386de1eb88c8d0a669d1e7fd88940d6 100644 --- a/src/OCE/SBC/sbcflx.F90 +++ b/src/OCE/SBC/sbcflx.F90 @@ -114,8 +114,8 @@ CONTAINS CALL ctl_stop( 'sbc_flx: unable to allocate sf structure' ) ; RETURN ENDIF DO ji= 1, jpfld - ALLOCATE( sf(ji)%fnow(jpi,jpj,1) ) - IF( slf_i(ji)%ln_tint ) ALLOCATE( sf(ji)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf(ji)%fnow(A2D(0),1) ) + IF( slf_i(ji)%ln_tint ) ALLOCATE( sf(ji)%fdta(A2D(0),1,2) ) END DO ! ! fill sf with slf_i and control print CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' ) @@ -129,29 +129,25 @@ CONTAINS IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! update ocean fluxes at each SBC frequency IF( ln_dm2dc ) THEN ! modify now Qsr to include the diurnal cycle - qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) + qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * smask0(:,:) ELSE - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - qsr(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1) - END_2D + qsr(:,:) = sf(jp_qsr)%fnow(:,:,1) * smask0(:,:) ENDIF #if defined key_top IF( ln_trcdc2dm ) THEN ! diurnal cycle in TOP IF( ln_dm2dc ) THEN - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - qsr_mean(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1) - END_2D + qsr_mean(:,:) = sf(jp_qsr)%fnow(:,:,1) * smask0(:,:) ELSE ncpl_qsr_freq = sf(jp_qsr)%freqh * 3600 ! qsr_mean will be computed in TOP ENDIF ENDIF #endif - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the ocean fluxes from read fields - utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) * tmask(ji,jj,1) - vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) * tmask(ji,jj,1) - qns (ji,jj) = ( sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) ) * tmask(ji,jj,1) - emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) * tmask(ji,jj,1) - !!sfx (ji,jj) = sf(jp_sfx )%fnow(ji,jj,1) * tmask(ji,jj,1) + DO_2D( 0, 0, 0, 0 ) ! set the ocean fluxes from read fields + utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) * smask0(ji,jj) + vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) * smask0(ji,jj) + qns (ji,jj) = ( sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) ) * smask0(ji,jj) + emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) * smask0(ji,jj) + !!sfx (ji,jj) = sf(jp_sfx )%fnow(ji,jj,1) * smask0(ji,jj) END_2D ! ! add to qns the heat due to e-p !!clem: I do not think it is needed @@ -173,8 +169,8 @@ CONTAINS ! ! module of wind stress and wind speed at T-point zcoef = 1. / ( zrhoa * zcdrag ) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - zmod = SQRT( utau(ji,jj) * utau(ji,jj) + vtau(ji,jj) * vtau(ji,jj) ) * tmask(ji,jj,1) + DO_2D( 0, 0, 0, 0 ) + zmod = SQRT( utau(ji,jj) * utau(ji,jj) + vtau(ji,jj) * vtau(ji,jj) ) * smask0(ji,jj) taum(ji,jj) = zmod wndm(ji,jj) = SQRT( zmod * zcoef ) !!clem: not used? END_2D diff --git a/src/OCE/SBC/sbcfwb.F90 b/src/OCE/SBC/sbcfwb.F90 index 58a17f028f4a7cc404859b8c7c4a66f98cd04406..7f9126cac1a1151ab8e3030c1387eb4e155f0b9d 100644 --- a/src/OCE/SBC/sbcfwb.F90 +++ b/src/OCE/SBC/sbcfwb.F90 @@ -16,7 +16,7 @@ MODULE sbcfwb USE oce ! ocean dynamics and tracers USE dom_oce ! ocean space and time domain USE sbc_oce ! surface ocean boundary condition - USE isf_oce , ONLY : fwfisf_cav, fwfisf_par ! ice shelf melting contribution + USE isf_oce , ONLY : fwfisf_cav, fwfisf_par, ln_isfcpl, ln_isfcpl_cons, risfcpl_cons_ssh ! ice shelf melting contribution USE sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass USE phycst ! physical constants USE sbcrnf ! ocean runoffs @@ -40,6 +40,8 @@ MODULE sbcfwb REAL(wp) :: a_fwb_ini ! initial domain averaged freshwater budget REAL(wp) :: area ! global mean ocean surface (interior domain) + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) !! $Id: sbcfwb.F90 15439 2021-10-22 17:53:09Z clem $ @@ -100,7 +102,7 @@ CONTAINS IF( kn_fwb == 3 .AND. nn_sssr /= 2 ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' ) IF( kn_fwb == 3 .AND. ln_isfcav ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' ) ! - area = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask(:,:,1)) ! interior global domain surface + area = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * smask0(:,:) ) ! interior global domain surface ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes ! and in case of no melt, it can generate HSSW. ! @@ -117,15 +119,15 @@ CONTAINS CASE ( 1 ) !== global mean fwf set to zero ==! ! IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN - y_fwfnow(1) = local_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) + y_fwfnow(1) = local_sum( e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) & + & - snwice_fmass(A2D(0)) ) ) CALL mpp_delay_sum( 'sbcfwb', 'fwb', y_fwfnow(:), z_fwfprv(:), kt == nitend - nn_fsbc + 1 ) - z_fwfprv(1) = z_fwfprv(1) / area - zcoef = z_fwfprv(1) * rcp - emp(:,:) = emp(:,:) - z_fwfprv(1) * tmask(:,:,1) - qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction + zcoef = z_fwfprv(1) / area + emp(A2D(0)) = emp(A2D(0)) - zcoef * smask0(:,:) + qns(:,:) = qns(:,:) + zcoef * rcp * sst_m(A2D(0)) * smask0(:,:) ! account for change to the heat budget due to fw correction ! outputs - IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', zcoef * sst_m(:,:) * tmask(:,:,1) ) - IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', z_fwfprv(1) * tmask(:,:,1) ) + IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', zcoef * rcp * sst_m(A2D(0)) * smask0(:,:) ) + IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', zcoef * smask0(:,:) ) ENDIF ! CASE ( 2 ) !== fw adjustment based on fw budget at the end of the previous year ==! @@ -136,7 +138,7 @@ CONTAINS & .AND. iom_varid( numror, 'a_fwb', ldstop = .FALSE. ) > 0 ) THEN IF(lwp) WRITE(numout,*) 'sbc_fwb : reading freshwater-budget from restart file' CALL iom_get( numror, 'a_fwb_b', a_fwb_b ) - CALL iom_get( numror, 'a_fwb' , a_fwb ) + CALL iom_get( numror, 'a_fwb' , a_fwb ) ! a_fwb_ini = a_fwb_b ELSE ! as specified in namelist @@ -168,11 +170,11 @@ CONTAINS ! IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes using previous year budget minus initial state zcoef = ( a_fwb - a_fwb_b ) - emp(:,:) = emp(:,:) + zcoef * tmask(:,:,1) - qns(:,:) = qns(:,:) - zcoef * rcp * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction + emp(A2D(0)) = emp(A2D(0)) + zcoef * smask0(:,:) + qns(:,:) = qns(:,:) - zcoef * rcp * sst_m(A2D(0)) * smask0(:,:) ! account for change to the heat budget due to fw correction ! outputs - IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zcoef * rcp * sst_m(:,:) * tmask(:,:,1) ) - IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zcoef * tmask(:,:,1) ) + IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zcoef * rcp * sst_m(A2D(0)) * smask0(:,:) ) + IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zcoef * smask0(:,:) ) ENDIF ! Output restart information IF( lrst_oce ) THEN @@ -190,53 +192,51 @@ CONTAINS ! CASE ( 3 ) !== global fwf set to zero and spread out over erp area ==! ! - ALLOCATE( ztmsk_neg(jpi,jpj) , ztmsk_pos(jpi,jpj) , ztmsk_tospread(jpi,jpj) , z_wgt(jpi,jpj) , zerp_cor(jpi,jpj) ) + ALLOCATE( ztmsk_neg(A2D(0)) , ztmsk_pos(A2D(0)) , ztmsk_tospread(A2D(0)) , z_wgt(A2D(0)) , zerp_cor(A2D(0)) ) ! IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN - ztmsk_pos(:,:) = tmask_i(:,:) ! Select <0 and >0 area of erp + ztmsk_pos(:,:) = smask0_i(:,:) ! Select <0 and >0 area of erp WHERE( erp < 0._wp ) ztmsk_pos = 0._wp - ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:) + ztmsk_neg(:,:) = smask0_i(:,:) - ztmsk_pos(:,:) ! ! fwf global mean (excluding ocean to ice/snow exchanges) - z_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) / area + z_fwf = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) & + & - snwice_fmass(A2D(0)) ) ) / area ! IF( z_fwf < 0._wp ) THEN ! spread out over >0 erp area to increase evaporation - zsurf_pos = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_pos(:,:) ) + zsurf_pos = glob_sum( 'sbcfwb', e1e2t(A2D(0))*ztmsk_pos(:,:) ) zsurf_tospread = zsurf_pos ztmsk_tospread(:,:) = ztmsk_pos(:,:) ELSE ! spread out over <0 erp area to increase precipitation - zsurf_neg = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_neg(:,:) ) ! Area filled by <0 and >0 erp + zsurf_neg = glob_sum( 'sbcfwb', e1e2t(A2D(0))*ztmsk_neg(:,:) ) ! Area filled by <0 and >0 erp zsurf_tospread = zsurf_neg ztmsk_tospread(:,:) = ztmsk_neg(:,:) ENDIF ! - zsum_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * z_fwf ) ! fwf global mean over <0 or >0 erp area + zsum_fwf = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * z_fwf ) ! fwf global mean over <0 or >0 erp area !!gm : zsum_fwf = z_fwf * area ??? it is right? I think so.... z_fwf_nsrf = zsum_fwf / ( zsurf_tospread + rsmall ) ! ! weight to respect erp field 2D structure - zsum_erp = glob_sum( 'sbcfwb', ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) ) + zsum_erp = glob_sum( 'sbcfwb', ztmsk_tospread(:,:) * erp(:,:) * e1e2t(A2D(0)) ) z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall ) ! ! final correction term to apply zerp_cor(:,:) = -1. * z_fwf_nsrf * zsurf_tospread * z_wgt(:,:) ! -!!gm ===>>>> lbc_lnk should be useless as all the computation is done over the whole domain ! - CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp ) - ! - emp(:,:) = emp(:,:) + zerp_cor(:,:) - qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:) ! account for change to the heat budget due to fw correction - erp(:,:) = erp(:,:) + zerp_cor(:,:) + emp(A2D(0)) = emp(A2D(0)) + zerp_cor(:,:) + qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(A2D(0)) ! account for change to the heat budget due to fw correction + erp(:,:) = erp(:,:) + zerp_cor(:,:) ! outputs - IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zerp_cor(:,:) * rcp * sst_m(:,:) ) + IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zerp_cor(:,:) * rcp * sst_m(A2D(0)) ) IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zerp_cor(:,:) ) ! IF( lwp ) THEN ! control print IF( z_fwf < 0._wp ) THEN WRITE(numout,*)' z_fwf < 0' - WRITE(numout,*)' SUM(erp+) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' + WRITE(numout,*)' SUM(erp+) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(A2D(0)) )*1.e-9,' Sv' ELSE WRITE(numout,*)' z_fwf >= 0' - WRITE(numout,*)' SUM(erp-) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' + WRITE(numout,*)' SUM(erp-) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(A2D(0)) )*1.e-9,' Sv' ENDIF - WRITE(numout,*)' SUM(empG) = ', SUM( z_fwf*e1e2t(:,:) )*1.e-9,' Sv' + WRITE(numout,*)' SUM(empG) = ', SUM( z_fwf*e1e2t(A2D(0)) )*1.e-9,' Sv' WRITE(numout,*)' z_fwf = ', z_fwf ,' Kg/m2/s' WRITE(numout,*)' z_fwf_nsrf = ', z_fwf_nsrf ,' Kg/m2/s' WRITE(numout,*)' MIN(zerp_cor) = ', MINVAL(zerp_cor) @@ -245,6 +245,31 @@ CONTAINS ENDIF DEALLOCATE( ztmsk_neg , ztmsk_pos , ztmsk_tospread , z_wgt , zerp_cor ) ! + CASE ( 4 ) !== global mean fwf set to zero (ISOMIP case) ==! + ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN + ! ! fwf global mean (excluding ocean to ice/snow exchanges) + zcoef = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) & + & - snwice_fmass(A2D(0)) ) ) / area + ! clem: use y_fwfnow instead to improve performance? + !y_fwfnow(1) = local_sum( e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) & + ! & - snwice_fmass(A2D(0)) ) ) + ! correction for ice sheet coupling testing (ie remove the excess through the surface) + ! test impact on the melt as conservation correction made in depth + ! test conservation level as sbcfwb is conserving + ! avoid the model to blow up for large ssh drop (isomip OCEAN3 with melt switch off and uniform T/S) + IF (ln_isfcpl .AND. ln_isfcpl_cons) THEN + zcoef = zcoef + glob_sum( 'sbcfwb', e1e2t(A2D(0)) * risfcpl_cons_ssh(A2D(0)) * rho0 ) / area + ! y_fwfnow(1) = y_fwfnow(1) + local_sum( e1e2t(A2D(0)) * risfcpl_cons_ssh(A2D(0)) * rho0 ) + END IF + !CALL mpp_delay_sum( 'sbcfwb', 'fwb', y_fwfnow(:), z_fwfprv(:), kt == nitend - nn_fsbc + 1 ) + !zcoef = z_fwfprv(1) / area + ! + emp(A2D(0)) = emp(A2D(0)) - zcoef * smask0(:,:) ! (Eq. 34 AD2015) + qns(:,:) = qns(:,:) + zcoef * rcp * sst_m(A2D(0)) * smask0(:,:) ! (Eq. 35 AD2015) ! use sst_m to avoid generation of any bouyancy fluxes + sfx(:,:) = sfx(:,:) + zcoef * sss_m(A2D(0)) * smask0(:,:) ! (Eq. 36 AD2015) ! use sss_m to avoid generation of any bouyancy fluxes + ENDIF + ! CASE DEFAULT !== you should never be there ==! CALL ctl_stop( 'sbc_fwb : wrong nn_fwb value for the FreshWater Budget correction, choose either 1, 2 or 3' ) ! diff --git a/src/OCE/SBC/sbcice_if.F90 b/src/OCE/SBC/sbcice_if.F90 index d5acb2918258945b4f211692d26a6fe6aab713ea..c406c7408c2a598b4241057d699e292b002ff454 100644 --- a/src/OCE/SBC/sbcice_if.F90 +++ b/src/OCE/SBC/sbcice_if.F90 @@ -85,8 +85,8 @@ CONTAINS ALLOCATE( sf_ice(1), STAT=ierror ) IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_if: unable to allocate sf_ice structure' ) - ALLOCATE( sf_ice(1)%fnow(jpi,jpj,1) ) - IF( sn_ice%ln_tint ) ALLOCATE( sf_ice(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf_ice(1)%fnow(A2D(0),1) ) + IF( sn_ice%ln_tint ) ALLOCATE( sf_ice(1)%fdta(A2D(0),1,2) ) ! fill sf_ice with sn_ice and control print CALL fld_fill( sf_ice, (/ sn_ice /), cn_dir, 'sbc_ice_if', 'ice-if sea-ice model', 'namsbc_iif' ) @@ -108,8 +108,12 @@ CONTAINS IF( ln_cpl ) a_i(:,:,1) = fr_i(:,:) ! Flux and ice fraction computation - DO_2D( 1, 1, 1, 1 ) - ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zt_fzp = fr_i(ji,jj) ! freezing point temperature + ts(ji,jj,1,jp_tem,Kmm) = MAX( ts(ji,jj,1,jp_tem,Kmm), zt_fzp ) ! avoid over-freezing point temperature + END_2D + + DO_2D( 0, 0, 0, 0 ) zt_fzp = fr_i(ji,jj) ! freezing point temperature zfr_obs = sf_ice(1)%fnow(ji,jj,1) ! observed ice cover ! ! ocean ice fraction (0/1) from the freezing point temperature @@ -117,8 +121,6 @@ CONTAINS ELSE ; fr_i(ji,jj) = 0.e0 ENDIF - ts(ji,jj,1,jp_tem,Kmm) = MAX( ts(ji,jj,1,jp_tem,Kmm), zt_fzp ) ! avoid over-freezing point temperature - qsr(ji,jj) = ( 1. - zfr_obs ) * qsr(ji,jj) ! solar heat flux : zero below observed ice cover ! ! non solar heat flux : add a damping term @@ -127,7 +129,7 @@ CONTAINS zqri = ztrp * ( ts(ji,jj,1,jp_tem,Kbb) - ( zt_fzp - 1.) ) zqrj = ztrp * MIN( 0., ts(ji,jj,1,jp_tem,Kbb) - zt_fzp ) zqrp = ( zfr_obs * ( (1. - fr_i(ji,jj) ) * zqri & - & + fr_i(ji,jj) * zqrj ) ) * tmask(ji,jj,1) + & + fr_i(ji,jj) * zqrj ) ) * smask0(ji,jj) ! ! non-solar heat flux ! # qns unchanged if no climatological ice (zfr_obs=0) @@ -136,7 +138,7 @@ CONTAINS ! (-2=arctic, -4=antarctic) zqi = -3. + SIGN( 1._wp, ff_f(ji,jj) ) qns(ji,jj) = ( ( 1.- zfr_obs ) * qns(ji,jj) & - & + zfr_obs * fr_i(ji,jj) * zqi ) * tmask(ji,jj,1) & + & + zfr_obs * fr_i(ji,jj) * zqi ) * smask0(ji,jj) & & + zqrp END_2D ! diff --git a/src/OCE/SBC/sbcmod.F90 b/src/OCE/SBC/sbcmod.F90 index 81f018a49b41a78742f19cd35af95216d31e43a4..78e2e3aeaaae7265949b30ced2b8bc29b0d0b2c9 100644 --- a/src/OCE/SBC/sbcmod.F90 +++ b/src/OCE/SBC/sbcmod.F90 @@ -51,6 +51,7 @@ MODULE sbcmod USE sbcfwb ! surface boundary condition: freshwater budget USE icbstp ! Icebergs USE icb_oce , ONLY : ln_passive_mode ! iceberg interaction mode + USE isf_oce , ONLY : ln_isf, l_isfoasis, fwfisf_oasis USE traqsr ! active tracers: light penetration USE sbcwave ! Wave module USE bdy_oce , ONLY: ln_bdy @@ -374,7 +375,7 @@ CONTAINS !! !! ** Action : - set the ocean surface boundary condition at before and now !! time step, i.e. - !! utau_b, vtau_b, qns_b, qsr_b, emp_n, sfx_b, qrp_b, erp_b + !! utau_b, vtau_b, qns_b, qsr_b, emp_b, sfx_b !! utau , vtau , qns , qsr , emp , sfx , qrp , erp !! - updte the ice fraction : fr_i !!---------------------------------------------------------------------- @@ -382,12 +383,10 @@ CONTAINS INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices INTEGER :: jj, ji ! dummy loop argument ! - LOGICAL :: ll_sas, ll_opa ! local logical + LOGICAL :: ll_sas, ll_opa ! local logical ! - REAL(wp) :: zthscl ! wd tanh scale - REAL(wp), DIMENSION(jpi,jpj) :: zwdht, zwght ! wd dep over wd limit, wgt - REAL(wp), DIMENSION(jpi,jpj) :: z2d ! temporary array used for iom_put - + REAL(wp) :: zthscl ! wd tanh scale + REAL(wp) :: zwdht, zwght ! wd dep over wd limit, wgt !!--------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('sbc') @@ -409,6 +408,8 @@ CONTAINS ! ! ---------------------------------------- ! ! ! forcing field computation ! ! ! ---------------------------------------- ! + ! most of the following routines update fields only in the interior + ! with the exception of sbcssm, sbcrnf and sbcwave modules ! ll_sas = nn_components == jp_iam_sas ! component flags ll_opa = nn_components == jp_iam_oce @@ -417,7 +418,6 @@ CONTAINS ! ! !== sbc formulation ==! ! - ! SELECT CASE( nsbc ) ! Compute ocean surface boundary condition ! ! (i.e. utau,vtau, qns, qsr, emp, sfx) CASE( jp_usr ) ; CALL usrdef_sbc_oce( kt, Kbb ) ! user defined formulation @@ -427,7 +427,7 @@ CONTAINS !!!!!!!!!!! ATTENTION:ln_wave is not only used for oasis coupling !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF( ln_wave ) THEN IF ( lk_oasis ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-wave coupling - CALL sbc_wave ( kt, Kmm ) + CALL sbc_wave ( kt, Kmm ) ENDIF CALL sbc_blk ( kt ) ! bulk formulation for the ocean ! @@ -444,7 +444,7 @@ CONTAINS ! IF( ln_wave .AND. ln_tauoc ) THEN ! Wave stress reduction ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) utau(ji,jj) = utau(ji,jj) * tauoc_wave(ji,jj) vtau(ji,jj) = vtau(ji,jj) * tauoc_wave(ji,jj) taum(ji,jj) = taum(ji,jj) * tauoc_wave(ji,jj) @@ -453,8 +453,8 @@ CONTAINS IF( kt == nit000 ) CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.', & & 'If not requested select ln_tauoc=.false.' ) ! - ELSEIF( ln_wave .AND. ln_taw ) THEN ! Wave stress reduction - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ELSEIF( ln_wave .AND. ln_taw ) THEN ! Wave stress reduction + DO_2D( 0, 0, 0, 0 ) utau(ji,jj) = utau(ji,jj) - tawx(ji,jj) + twox(ji,jj) vtau(ji,jj) = vtau(ji,jj) - tawy(ji,jj) + twoy(ji,jj) taum(ji,jj) = SQRT( utau(ji,jj)*utau(ji,jj) + vtau(ji,jj)*vtau(ji,jj) ) @@ -465,10 +465,17 @@ CONTAINS ! ENDIF ! + !clem: these calls are needed for sbccpl only => only for SAS I think? + IF( ll_sas .OR. ll_opa ) CALL lbc_lnk( 'sbcmod', sst_m, 'T', 1.0_wp, sss_m, 'T', 1.0_wp, ssh_m, 'T', 1.0_wp, & + & frq_m, 'T', 1.0_wp, e3t_m, 'T', 1.0_wp, fr_i , 'T', 1.0_wp ) + !clem : these calls are needed for sbccpl => it needs an IF statement but it's complicated + IF( ln_isf .AND. l_isfoasis ) CALL lbc_lnk( 'sbcmod', fwfisf_oasis, 'T', 1.0_wp ) + IF( ln_rnf .AND. l_rnfcpl ) CALL lbc_lnk( 'sbcmod', rnf, 'T', 1.0_wp, fwficb , 'T', 1.0_wp ) ! IF( ln_icebergs ) THEN ! save pure stresses (with no ice-ocean stress) for use by icebergs ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines ! and the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves + CALL lbc_lnk( 'sbcmod', utau, 'T', -1.0_wp, vtau, 'T', -1.0_wp ) DO_2D( 0, 0, 0, 0 ) utau_icb(ji,jj) = 0.5_wp * ( utau(ji,jj) + utau(ji+1,jj) ) * & & ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji+1,jj,1) ) @@ -480,26 +487,26 @@ CONTAINS ! ! !== Misc. Options ==! ! - SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas - CASE( 1 ) ; CALL sbc_ice_if ( kt, Kbb, Kmm ) ! Ice-cover climatology ("Ice-if" model) + SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas + CASE( 1 ) ; CALL sbc_ice_if ( kt, Kbb, Kmm ) ! Ice-cover climatology ("Ice-if" model) #if defined key_si3 - CASE( 2 ) ; CALL ice_stp ( kt, Kbb, Kmm, nsbc ) ! SI3 ice model + CASE( 2 ) ; CALL ice_stp ( kt, Kbb, Kmm, nsbc ) ! SI3 ice model #endif - CASE( 3 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model + CASE( 3 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model END SELECT - - IF( ln_icebergs ) CALL icb_stp( kt, Kmm ) ! compute icebergs + !==> clem: from here on, the following fields are ok on the halos: snwice_mass, snwice_mass_b, snwice_fmass + ! but not utau, vtau, emp (must be done later on) + + IF( ln_icebergs ) CALL icb_stp( kt, Kmm ) ! compute icebergs ! Icebergs do not melt over the haloes. ! So emp values over the haloes are no more consistent with the inner domain values. ! A lbc_lnk is therefore needed to ensure reproducibility and restartability. ! see ticket #2113 for discussion about this lbc_lnk. - ! The lbc_lnk is also needed for SI3 with nn_hls > 1 as emp is not yet defined for these points in iceupdate.F90 - IF( (ln_icebergs .AND. .NOT. ln_passive_mode) .OR. (nn_ice == 2 .AND. nn_hls == 2) ) THEN - CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) - ENDIF - - IF( ln_rnf ) CALL sbc_rnf( kt ) ! add runoffs to fresh water fluxes +!!$ IF( ln_icebergs .AND. .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) + !clem: not needed anymore since lbc is done afterwards + + IF( ln_rnf ) CALL sbc_rnf( kt ) ! add runoffs to fresh water fluxes IF( ln_ssr ) CALL sbc_ssr( kt ) ! add SST/SSS damping term @@ -511,27 +518,36 @@ CONTAINS IF( ll_wd ) THEN ! If near WAD point limit the flux for now zthscl = atanh(rn_wd_sbcfra) ! taper frac default is .999 - zwdht(:,:) = ssh(:,:,Kmm) + ht_0(:,:) - rn_wdmin1 ! do this calc of water - ! depth above wd limit once - WHERE( zwdht(:,:) <= 0.0 ) - taum(:,:) = 0.0 - utau(:,:) = 0.0 - vtau(:,:) = 0.0 - qns (:,:) = 0.0 - qsr (:,:) = 0.0 - emp (:,:) = min(emp(:,:),0.0) !can allow puddles to grow but not shrink - sfx (:,:) = 0.0 - END WHERE - zwght(:,:) = tanh(zthscl*zwdht(:,:)) - WHERE( zwdht(:,:) > 0.0 .and. zwdht(:,:) < rn_wd_sbcdep ) ! 5 m hard limit here is arbitrary - qsr (:,:) = qsr(:,:) * zwght(:,:) - qns (:,:) = qns(:,:) * zwght(:,:) - taum (:,:) = taum(:,:) * zwght(:,:) - utau (:,:) = utau(:,:) * zwght(:,:) - vtau (:,:) = vtau(:,:) * zwght(:,:) - sfx (:,:) = sfx(:,:) * zwght(:,:) - emp (:,:) = emp(:,:) * zwght(:,:) - END WHERE + DO_2D( 0, 0, 0, 0 ) + zwdht = ssh(ji,jj,Kmm) + ht_0(ji,jj) - rn_wdmin1 ! do this calc of water depth above wd limit once + zwght = TANH(zthscl*zwdht) + IF( zwdht <= 0.0 ) THEN + taum(ji,jj) = 0.0 + utau(ji,jj) = 0.0 + vtau(ji,jj) = 0.0 + qns (ji,jj) = 0.0 + qsr (ji,jj) = 0.0 + emp (ji,jj) = MIN(emp(ji,jj),0.0) !can allow puddles to grow but not shrink + sfx (ji,jj) = 0.0 + ELSEIF( zwdht > 0.0 .AND. zwdht < rn_wd_sbcdep ) THEN ! 5 m hard limit here is arbitrary + qsr (ji,jj) = qsr(ji,jj) * zwght + qns (ji,jj) = qns(ji,jj) * zwght + taum (ji,jj) = taum(ji,jj) * zwght + utau (ji,jj) = utau(ji,jj) * zwght + vtau (ji,jj) = vtau(ji,jj) * zwght + sfx (ji,jj) = sfx(ji,jj) * zwght + emp (ji,jj) = emp(ji,jj) * zwght + ENDIF + END_2D + ENDIF + + ! clem: these should be the only fields that are needed over the entire domain + ! (in addition to snwice_mass) + IF( ln_rnf ) THEN + CALL lbc_lnk( 'sbcmod', utau, 'T', -1.0_wp, vtau , 'T', -1.0_wp, emp, 'T', 1.0_wp, & + & rnf , 'T', 1.0_wp, fwficb, 'T', 1.0_wp ) ! fwficb is used on the halos in pisces (only) + ELSE + CALL lbc_lnk( 'sbcmod', utau, 'T', -1.0_wp, vtau , 'T', -1.0_wp, emp, 'T', 1.0_wp ) ENDIF ! --- calculate utau and vtau on U,V-points --- ! ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines @@ -600,29 +616,14 @@ CONTAINS ! ! Outputs and control print ! ! ! ---------------------------------------- ! IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN - IF( iom_use("empmr") ) THEN - DO_2D( 0, 0, 0, 0 ) - z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) - END_2D - CALL iom_put( "empmr" , z2d ) ! upward water flux - ENDIF - IF( iom_use("empbmr") ) THEN - DO_2D( 0, 0, 0, 0 ) - z2d(ji,jj) = emp_b(ji,jj) - rnf(ji,jj) - END_2D - CALL iom_put( "empbmr" , z2d ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) - ENDIF - CALL iom_put( "saltflx", sfx ) ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case) + CALL iom_put( "empmr" , emp(A2D(0))-rnf(A2D(0)) ) ! upward water flux + CALL iom_put( "empbmr" , emp_b(A2D(0))-rnf(A2D(0)) ) ! before upward water flux (for ssh in offline ) + CALL iom_put( "saltflx", sfx ) ! downward salt flux CALL iom_put( "fmmflx" , fmmflx ) ! Freezing-melting water flux - IF( iom_use("qt") ) THEN - DO_2D( 0, 0, 0, 0 ) - z2d(ji,jj) = qns(ji,jj) + qsr(ji,jj) - END_2D - CALL iom_put( "qt" , z2d ) ! total heat flux - ENDIF + CALL iom_put( "qt" , qns+qsr ) ! total heat flux CALL iom_put( "qns" , qns ) ! solar heat flux CALL iom_put( "qsr" , qsr ) ! solar heat flux - IF( nn_ice > 0 .OR. ll_opa ) CALL iom_put( "ice_cover", fr_i ) ! ice fraction + IF( nn_ice > 0 .OR. ll_opa ) CALL iom_put( "ice_cover", fr_i(:,:) ) ! ice fraction CALL iom_put( "taum" , taum ) ! wind stress module CALL iom_put( "wspd" , wndm ) ! wind speed module over free ocean or leads in presence of sea-ice CALL iom_put( "qrp" , qrp ) ! heat flux damping @@ -632,12 +633,12 @@ CONTAINS IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask ) CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask ) - CALL prt_ctl(tab2d_1=(sfx-rnf) , clinfo1=' sfx-rnf - : ', mask1=tmask ) + CALL prt_ctl(tab2d_1=(sfx-rnf(A2D(0))) , clinfo1=' sfx-rnf - : ', mask1=tmask ) CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask ) CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask ) CALL prt_ctl(tab3d_1=tmask , clinfo1=' tmask - : ', mask1=tmask, kdim=jpk ) - CALL prt_ctl(tab3d_1=ts(:,:,:,jp_tem,Kmm), clinfo1=' sst - : ', mask1=tmask, kdim=1 ) - CALL prt_ctl(tab3d_1=ts(:,:,:,jp_sal,Kmm), clinfo1=' sss - : ', mask1=tmask, kdim=1 ) + CALL prt_ctl(tab2d_1=sst_m , clinfo1=' sst - : ', mask1=tmask ) + CALL prt_ctl(tab2d_1=sss_m , clinfo1=' sss - : ', mask1=tmask ) CALL prt_ctl(tab2d_1=utau , clinfo1=' utau - : ', mask1=tmask, & & tab2d_2=vtau , clinfo2=' vtau - : ', mask2=tmask ) ENDIF diff --git a/src/OCE/SBC/sbcrnf.F90 b/src/OCE/SBC/sbcrnf.F90 index 758d4f4ba0c3038309ca5c2a251381b8e3ff438a..367e3c7cf4f7a077be154f874d2145f3b69c3c64 100644 --- a/src/OCE/SBC/sbcrnf.F90 +++ b/src/OCE/SBC/sbcrnf.F90 @@ -83,9 +83,9 @@ CONTAINS !!---------------------------------------------------------------------- !! *** ROUTINE sbc_rnf_alloc *** !!---------------------------------------------------------------------- - ALLOCATE( rnfmsk(jpi,jpj) , rnfmsk_z(jpk) , & - & h_rnf (jpi,jpj) , nk_rnf (jpi,jpj) , & - & rnf_tsc_b(jpi,jpj,jpts) , rnf_tsc (jpi,jpj,jpts) , STAT=sbc_rnf_alloc ) + ALLOCATE( rnfmsk(jpi,jpj) , rnfmsk_z(jpk) , & + & h_rnf (jpi,jpj) , nk_rnf (jpi,jpj) , & + & rnf_tsc_b(A2D(0),jpts) , rnf_tsc (A2D(0),jpts) , STAT=sbc_rnf_alloc ) ! CALL mpp_sum ( 'sbcrnf', sbc_rnf_alloc ) IF( sbc_rnf_alloc > 0 ) CALL ctl_warn('sbc_rnf_alloc: allocation of arrays failed') @@ -109,8 +109,6 @@ CONTAINS INTEGER :: ji, jj ! dummy loop indices INTEGER :: z_err = 0 ! dummy integer for error handling !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point used for temperature correction - ! ! ! !-------------------! ! ! Update runoff ! @@ -118,8 +116,8 @@ CONTAINS ! ! IF( .NOT. l_rnfcpl ) THEN - CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt ( runoffs + iceberg ) - IF( ln_rnf_icb ) CALL fld_read ( kt, nn_fsbc, sf_i_rnf ) ! idem for iceberg flux if required + CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt ( runoffs + iceberg ) + IF( ln_rnf_icb ) CALL fld_read ( kt, nn_fsbc, sf_i_rnf ) ! idem for iceberg flux if required ENDIF IF( ln_rnf_tem ) CALL fld_read ( kt, nn_fsbc, sf_t_rnf ) ! idem for runoffs temperature if required IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required @@ -127,33 +125,32 @@ CONTAINS IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN ! IF( .NOT. l_rnfcpl ) THEN - rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt + rnf(A2D(0)) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) * smask0(:,:) ! updated runoff value at time step kt IF( ln_rnf_icb ) THEN - fwficb(:,:) = rn_rfact * ( sf_i_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt - rnf(:,:) = rnf(:,:) + fwficb(:,:) - qns(:,:) = qns(:,:) - fwficb(:,:) * rLfus + fwficb(A2D(0)) = rn_rfact * ( sf_i_rnf(1)%fnow(:,:,1) ) * smask0(:,:) ! updated runoff value at time step kt + rnf(A2D(0)) = rnf(A2D(0)) + fwficb(A2D(0)) + qns(:,:) = qns(:,:) - fwficb(A2D(0)) * rLfus !!qns_tot(:,:) = qns_tot(:,:) - fwficb(:,:) * rLfus !!qns_oce(:,:) = qns_oce(:,:) - fwficb(:,:) * rLfus - CALL iom_put( 'iceberg_cea' , fwficb(:,:) ) ! output iceberg flux - CALL iom_put( 'hflx_icb_cea' , -fwficb(:,:) * rLfus ) ! output Heat Flux into Sea Water due to Iceberg Thermodynamics --> + CALL iom_put( 'iceberg_cea' , fwficb(A2D(0)) ) ! output iceberg flux + CALL iom_put( 'hflx_icb_cea' , -fwficb(A2D(0)) * rLfus ) ! output Heat Flux into Sea Water due to Iceberg Thermodynamics --> ENDIF ENDIF ! ! ! set temperature & salinity content of runoffs IF( ln_rnf_tem ) THEN ! use runoffs temperature data - rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rho0 - CALL eos_fzp( sss_m(:,:), ztfrz(:,:) ) + rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(A2D(0)) * r1_rho0 WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp ) ! if missing data value use SST as runoffs temperature - rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rho0 + rnf_tsc(:,:,jp_tem) = sst_m(A2D(0)) * rnf(A2D(0)) * r1_rho0 END WHERE ELSE ! use SST as runoffs temperature !CEOD River is fresh water so must at least be 0 unless we consider ice - rnf_tsc(:,:,jp_tem) = MAX( sst_m(:,:), 0.0_wp ) * rnf(:,:) * r1_rho0 + rnf_tsc(:,:,jp_tem) = MAX( sst_m(A2D(0)), 0.0_wp ) * rnf(A2D(0)) * r1_rho0 ENDIF ! ! use runoffs salinity data - IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rho0 + IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(A2D(0)) * r1_rho0 ! ! else use S=0 for runoffs (done one for all in the init) - CALL iom_put( 'runoffs' , rnf(:,:) ) ! output runoff mass flux + CALL iom_put( 'runoffs' , rnf(A2D(0)) ) ! output runoff mass flux IF( iom_use('hflx_rnf_cea') ) CALL iom_put( 'hflx_rnf_cea', rnf_tsc(:,:,jp_tem) * rho0 * rcp ) ! output runoff sensible heat (W/m2) IF( iom_use('sflx_rnf_cea') ) CALL iom_put( 'sflx_rnf_cea', rnf_tsc(:,:,jp_sal) * rho0 ) ! output runoff salt flux (g/m2/s) ENDIF @@ -168,13 +165,15 @@ CONTAINS CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) ) ! before salinity content of runoff ELSE !* no restart: set from nit000 values IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' - rnf_b (:,: ) = rnf (:,: ) - rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) + CALL lbc_lnk( 'sbcrnf', rnf, 'T', 1.0_wp ) + rnf_b (:,:) = rnf (:,:) + rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) ENDIF ENDIF ! ! ---------------------------------------- ! IF( lrst_oce ) THEN ! Write in the ocean restart file ! ! ! ---------------------------------------- ! + ! IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) 'sbcrnf : runoff forcing fields written in ocean restart file ', & & 'at it= ', kt,' date= ', ndastp @@ -323,8 +322,8 @@ CONTAINS IF( ierror > 0 ) THEN CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_rnf structure' ) ; RETURN ENDIF - ALLOCATE( sf_rnf(1)%fnow(jpi,jpj,1) ) - IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf_rnf(1)%fnow(A2D(0),1) ) + IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(A2D(0),1,2) ) CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf', no_print ) ! IF( ln_rnf_icb ) THEN ! Create (if required) sf_i_rnf structure @@ -334,11 +333,13 @@ CONTAINS IF( ierror > 0 ) THEN CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_i_rnf structure' ) ; RETURN ENDIF - ALLOCATE( sf_i_rnf(1)%fnow(jpi,jpj,1) ) - IF( sn_i_rnf%ln_tint ) ALLOCATE( sf_i_rnf(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf_i_rnf(1)%fnow(A2D(0),1) ) + IF( sn_i_rnf%ln_tint ) ALLOCATE( sf_i_rnf(1)%fdta(A2D(0),1,2) ) CALL fld_fill (sf_i_rnf, (/ sn_i_rnf /), cn_dir, 'sbc_rnf_init', 'read iceberg flux data', 'namsbc_rnf' ) ELSE - fwficb(:,:) = 0._wp + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + fwficb(ji,jj) = 0._wp + END_2D ENDIF ENDIF @@ -350,8 +351,8 @@ CONTAINS IF( ierror > 0 ) THEN CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' ) ; RETURN ENDIF - ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1) ) - IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf_t_rnf(1)%fnow(A2D(0),1) ) + IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(A2D(0),1,2) ) CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf', no_print ) ENDIF ! @@ -362,8 +363,8 @@ CONTAINS IF( ierror > 0 ) THEN CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' ) ; RETURN ENDIF - ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1) ) - IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf_s_rnf(1)%fnow(A2D(0),1) ) + IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(A2D(0),1,2) ) CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf', no_print ) ENDIF ! @@ -378,8 +379,7 @@ CONTAINS CALL iom_get ( inum, jpdom_global, sn_dep_rnf%clvar, h_rnf, kfill = jpfillcopy ) ! read the river mouth. no 0 on halos! CALL iom_close( inum ) ! close file ! - nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the number of level over which river runoffs are applied IF( h_rnf(ji,jj) > 0._wp ) THEN jk = 2 DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 @@ -392,7 +392,8 @@ CONTAINS WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) ENDIF END_2D - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the associated depth + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the associated depth h_rnf(ji,jj) = 0._wp DO jk = 1, nk_rnf(ji,jj) h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) @@ -407,7 +408,7 @@ CONTAINS IF(lwp) WRITE(numout,*) ' depth over which runoffs is spread rn_dep_max = ', rn_dep_max IF(lwp) WRITE(numout,*) ' create (=1) a runoff depth file or not (=0) nn_rnf_depth_file = ', nn_rnf_depth_file - CALL iom_open( TRIM( sn_rnf%clname ), inum ) ! open runoff file + CALL iom_open( TRIM( sn_rnf%clname ), inum ) ! open runoff file nbrec = iom_getszuld( inum ) zrnfcl(:,:,1) = 0._wp ! init the max to 0. in 1 DO jm = 1, nbrec @@ -416,21 +417,20 @@ CONTAINS END DO CALL iom_close( inum ) ! - h_rnf(:,:) = 1. - ! - zacoef = rn_dep_max / rn_rnf_max ! coef of linear relation between runoff and its depth (150m for max of runoff) + zacoef = rn_dep_max / rn_rnf_max ! coef of linear relation between runoff and its depth (150m for max of runoff) ! - WHERE( zrnfcl(:,:,1) > 0._wp ) h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs + WHERE( zrnfcl(:,:,1) > 0._wp ) ; h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs + ELSEWHERE ; h_rnf(:,:) = 1._wp + ENDWHERE ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! take in account min depth of ocean rn_hmin + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! take in account min depth of ocean rn_hmin IF( zrnfcl(ji,jj,1) > 0._wp ) THEN jk = mbkt(ji,jj) h_rnf(ji,jj) = MIN( h_rnf(ji,jj), gdept_0(ji,jj,jk ) ) ENDIF END_2D ! - nk_rnf(:,:) = 0 ! number of levels on which runoffs are distributed - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! number of levels on which runoffs are distributed IF( zrnfcl(ji,jj,1) > 0._wp ) THEN jk = 2 DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 @@ -441,27 +441,33 @@ CONTAINS ENDIF END_2D ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the associated depth + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the associated depth h_rnf(ji,jj) = 0._wp DO jk = 1, nk_rnf(ji,jj) h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) END DO END_2D ! - IF( nn_rnf_depth_file == 1 ) THEN ! save output nb levels for runoff + IF( nn_rnf_depth_file == 1 ) THEN ! save output nb levels for runoff IF(lwp) WRITE(numout,*) ' ==>>> create runoff depht file' CALL iom_open ( TRIM( sn_dep_rnf%clname ), inum, ldwrt = .TRUE. ) CALL iom_rstput( 0, 0, inum, 'rodepth', h_rnf ) CALL iom_close ( inum ) ENDIF - ELSE ! runoffs applied at the surface - nk_rnf(:,:) = 1 - h_rnf (:,:) = e3t(:,:,1,Kmm) + ELSE ! runoffs applied at the surface + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + nk_rnf(ji,jj) = 1 + h_rnf (ji,jj) = e3t(ji,jj,1,Kmm) + END_2D ENDIF ! - rnf(:,:) = 0._wp ! runoff initialisation - rnf_tsc(:,:,:) = 0._wp ! runoffs temperature & salinty contents initilisation - ! + DO_2D( 0, 0, 0, 0 ) + rnf(ji,jj) = 0._wp ! runoff initialisation + END_2D + DO_3D( 0, 0, 0, 0, 1, jpts ) + rnf_tsc(ji,jj,jk) = 0._wp ! runoffs temperature & salinty contents initilisation + END_3D + ! ! ! ======================== ! ! River mouth vicinity ! ! ======================== @@ -493,11 +499,13 @@ CONTAINS ELSE ! No treatment at river mouths IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) ' ==>>> No specific treatment at river mouths' - rnfmsk (:,:) = 0._wp + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + rnfmsk(ji,jj) = 0._wp + END_2D rnfmsk_z(:) = 0._wp nkrnf = 0 ENDIF - ! + ! END SUBROUTINE sbc_rnf_init diff --git a/src/OCE/SBC/sbcssr.F90 b/src/OCE/SBC/sbcssr.F90 index 09088c45c0e777ab2ef5e70f86db178cfa2a2470..2b607dbb95b6257935b108d45edcc1733e6b06b3 100644 --- a/src/OCE/SBC/sbcssr.F90 +++ b/src/OCE/SBC/sbcssr.F90 @@ -97,8 +97,8 @@ CONTAINS erp(:,:) = 0._wp ! IF( nn_sstr == 1 ) THEN !* Temperature restoring term - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1) + DO_2D( 0, 0, 0, 0 ) + zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) * smask0(ji,jj) qns(ji,jj) = qns(ji,jj) + zqrp qrp(ji,jj) = zqrp END_2D @@ -107,7 +107,7 @@ CONTAINS IF( nn_sssr /= 0 .AND. nn_sssr_ice /= 1 ) THEN ! use fraction of ice ( fr_i ) to adjust relaxation under ice if nn_sssr_ice .ne. 1 ! n.b. coefice is initialised and fixed to 1._wp if nn_sssr_ice = 1 - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) SELECT CASE ( nn_sssr_ice ) CASE ( 0 ) ; coefice(ji,jj) = 1._wp - fr_i(ji,jj) ! no/reduced damping under ice CASE DEFAULT ; coefice(ji,jj) = 1._wp + ( nn_sssr_ice - 1 ) * fr_i(ji,jj) ! reinforced damping (x nn_sssr_ice) under ice ) @@ -117,10 +117,10 @@ CONTAINS ! IF( nn_sssr == 1 ) THEN !* Salinity damping term (salt flux only (sfx)) zsrp = rn_deds / rday ! from [mm/day] to [kg/m2/s] - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths & * coefice(ji,jj) & ! Optional control of damping under sea-ice - & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1) + & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) * smask0(ji,jj) sfx(ji,jj) = sfx(ji,jj) + zerp ! salt flux erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only) END_2D @@ -128,21 +128,21 @@ CONTAINS ELSEIF( nn_sssr == 2 ) THEN !* Salinity damping term (volume flux (emp) and associated heat flux (qns) zsrp = rn_deds / rday ! from [mm/day] to [kg/m2/s] zerp_bnd = rn_sssr_bnd / rday ! - - - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths & * coefice(ji,jj) & ! Optional control of damping under sea-ice & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) & - & / MAX( sss_m(ji,jj), 1.e-20 ) * tmask(ji,jj,1) + & / MAX( sss_m(ji,jj), 1.e-20 ) * smask0(ji,jj) IF( ln_sssr_bnd ) zerp = SIGN( 1.0_wp, zerp ) * MIN( zerp_bnd, ABS(zerp) ) - emp(ji,jj) = emp (ji,jj) + zerp - qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj) erp(ji,jj) = zerp - qrp(ji,jj) = qrp(ji,jj) - zerp * rcp * sst_m(ji,jj) + emp(ji,jj) = emp(ji,jj) + erp(ji,jj) + qns(ji,jj) = qns(ji,jj) - erp(ji,jj) * rcp * sst_m(ji,jj) + qrp(ji,jj) = qrp(ji,jj) - erp(ji,jj) * rcp * sst_m(ji,jj) END_2D ENDIF ! outputs CALL iom_put( 'hflx_ssr_cea', qrp(:,:) ) - IF( nn_sssr == 1 ) CALL iom_put( 'sflx_ssr_cea', erp(:,:) * sss_m(:,:) ) + IF( nn_sssr == 1 ) CALL iom_put( 'sflx_ssr_cea', erp(:,:) * sss_m(A2D(0)) ) IF( nn_sssr == 2 ) CALL iom_put( 'vflx_ssr_cea', -erp(:,:) ) ! ENDIF @@ -207,12 +207,12 @@ CONTAINS ! ALLOCATE( sf_sst(1), STAT=ierror ) IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' ) - ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror ) + ALLOCATE( sf_sst(1)%fnow(A2D(0),1), STAT=ierror ) IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' ) ! ! fill sf_sst with sn_sst and control print CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr', no_print ) - IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror ) + IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(A2D(0),1,2), STAT=ierror ) IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' ) ! ENDIF @@ -221,12 +221,12 @@ CONTAINS ! ALLOCATE( sf_sss(1), STAT=ierror ) IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' ) - ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror ) + ALLOCATE( sf_sss(1)%fnow(A2D(0),1), STAT=ierror ) IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' ) ! ! fill sf_sss with sn_sss and control print CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr', no_print ) - IF( sf_sss(1)%ln_tint ) ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror ) + IF( sf_sss(1)%ln_tint ) ALLOCATE( sf_sss(1)%fdta(A2D(0),1,2), STAT=ierror ) IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' ) ! ENDIF @@ -244,7 +244,7 @@ CONTAINS !!---------------------------------------------------------------------- sbc_ssr_alloc = 0 ! set to zero if no array to be allocated IF( .NOT. ALLOCATED( erp ) ) THEN - ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), coefice(jpi,jpj), STAT= sbc_ssr_alloc ) + ALLOCATE( qrp(A2D(0)), erp(A2D(0)), coefice(A2D(0)), STAT= sbc_ssr_alloc ) ! IF( lk_mpp ) CALL mpp_sum ( 'sbcssr', sbc_ssr_alloc ) IF( sbc_ssr_alloc /= 0 ) CALL ctl_warn('sbc_ssr_alloc: failed to allocate arrays.') diff --git a/src/OCE/SBC/sbcwave.F90 b/src/OCE/SBC/sbcwave.F90 index 2264938d72a9f274537fd9378d55ba6e458c38c4..cb0b219ef973ccb16666824974e2887977e6908f 100644 --- a/src/OCE/SBC/sbcwave.F90 +++ b/src/OCE/SBC/sbcwave.F90 @@ -115,14 +115,13 @@ CONTAINS INTEGER :: jj, ji, jk ! dummy loop argument INTEGER :: ik ! local integer REAL(wp) :: ztransp, zfac, ztemp, zsp0, zsqrt, zbreiv16_w - REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp + REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp, zInt_w0, zInt_w1 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace - REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh, zInt_w ! 3D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh ! 3D workspace !!--------------------------------------------------------------------- ! ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined - ALLOCATE( zInt_w(jpi,jpj,jpk) ) - ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) ) + ALLOCATE( zk_t(A2D(1)), zk_u(A2D(0)), zk_v(A2D(0)), zu0_sd(A2D(1)), zv0_sd(A2D(1)) ) zk_t (:,:) = 0._wp zk_u (:,:) = 0._wp zk_v (:,:) = 0._wp @@ -138,7 +137,7 @@ CONTAINS ! sdtrp is the norm of Stokes transport ! zfac = 0.166666666667_wp - DO_2D( 1, 1, 1, 1 ) ! In the deep-water limit we have ke = ||ust0||/( 6 * ||transport|| ) + DO_2D( 0, 1, 0, 1 ) ! In the deep-water limit we have ke = ||ust0||/( 6 * ||transport|| ) zsp0 = SQRT( ut0sd(ji,jj)*ut0sd(ji,jj) + vt0sd(ji,jj)*vt0sd(ji,jj) ) !<-- norm of Surface Stokes drift tsd2d(ji,jj) = zsp0 IF( cpl_tusd .AND. cpl_tvsd ) THEN !stokes transport is provided in coupled mode @@ -150,35 +149,40 @@ CONTAINS ENDIF zk_t (ji,jj) = zfac * zsp0 / MAX ( sdtrp, 0.0000001_wp ) !<-- ke = ||ust0||/( 6 * ||transport|| ) END_2D - !# define zInt_w ze3divh - DO_3D( 1, 1, 1, 1, 1, jpk ) ! Compute the primitive of Breivik 2016 function at W-points - zfac = - 2._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) !<-- zfac should be negative definite - ztemp = EXP ( zfac ) - zsqrt = SQRT( -zfac ) - zbreiv16_w = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016 - zInt_w(ji,jj,jk) = ztemp - 4._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) * zbreiv16_w - END_3D -! + ! DO jk = 1, jpkm1 zfac = 0.166666666667_wp - DO_2D( 1, 1, 1, 1 ) !++ Compute the FV Breivik 2016 function at T-points + DO_2D( 0, 1, 0, 1 ) !++ Compute the FV Breivik 2016 function at T-points + ! zInt at jk + zfac = - 2._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) !<-- zfac should be negative definite + ztemp = EXP ( zfac ) + zsqrt = SQRT( -zfac ) + zbreiv16_w = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016 + zInt_w0 = ztemp - 4._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) * zbreiv16_w + ! zInt at jk+1 + zfac = - 2._wp * zk_t (ji,jj) * gdepw(ji,jj,jk+1,Kmm) !<-- zfac should be negative definite + ztemp = EXP ( zfac ) + zsqrt = SQRT( -zfac ) + zbreiv16_w = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016 + zInt_w1 = ztemp - 4._wp * zk_t (ji,jj) * gdepw(ji,jj,jk+1,Kmm) * zbreiv16_w + ! + ! zsp0 = zfac / MAX(zk_t (ji,jj),0.0000001_wp) - ztemp = zInt_w(ji,jj,jk) - zInt_w(ji,jj,jk+1) + ztemp = zInt_w0 - zInt_w1 zu0_sd(ji,jj) = ut0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) zv0_sd(ji,jj) = vt0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) END_2D - DO_2D( 1, 0, 1, 0 ) ! ++ Interpolate at U/V points + DO_2D( 0, 0, 0, 0 ) ! ++ Interpolate at U/V points zfac = 1.0_wp / e3u(ji ,jj,jk,Kmm) usd(ji,jj,jk) = 0.5_wp * zfac * ( zu0_sd(ji,jj)+zu0_sd(ji+1,jj) ) * umask(ji,jj,jk) zfac = 1.0_wp / e3v(ji ,jj,jk,Kmm) vsd(ji,jj,jk) = 0.5_wp * zfac * ( zv0_sd(ji,jj)+zv0_sd(ji,jj+1) ) * vmask(ji,jj,jk) END_2D ENDDO - !# undef zInt_w - ! + ! ELSE zfac = 2.0_wp * rpi / 16.0_wp - DO_2D( 1, 1, 1, 1 ) + DO_2D( 0, 1, 0, 1 ) ! Stokes drift velocity estimated from Hs and Tmean ztransp = zfac * hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp ) ! Stokes surface speed @@ -186,7 +190,7 @@ CONTAINS ! Wavenumber scale zk_t(ji,jj) = ABS( tsd2d(ji,jj) ) / MAX( ABS( 5.97_wp*ztransp ), 0.0000001_wp ) END_2D - DO_2D( 1, 0, 1, 0 ) ! exp. wave number & Stokes drift velocity at u- & v-points + DO_2D( 0, 0, 0, 0 ) ! exp. wave number & Stokes drift velocity at u- & v-points zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) ) zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) ) ! @@ -248,7 +252,7 @@ CONTAINS CALL iom_put( "vstokes", vsd ) CALL iom_put( "wstokes", wsd ) ! ! - DEALLOCATE( ze3divh, zInt_w ) + DEALLOCATE( ze3divh ) DEALLOCATE( zk_t, zk_u, zk_v, zu0_sd, zv0_sd ) ! END SUBROUTINE sbc_stokes @@ -274,12 +278,12 @@ CONTAINS ! IF( ln_cdgw .AND. .NOT. cpl_wdrag ) THEN !== Neutral drag coefficient ==! CALL fld_read( kt, nn_fsbc, sf_cd ) ! read from external forcing - cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1) * tmask(:,:,1) + cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1) * smask0(:,:) ENDIF IF( ln_tauoc .AND. .NOT. cpl_wstrf ) THEN !== Wave induced stress ==! CALL fld_read( kt, nn_fsbc, sf_tauoc ) ! read stress reduction factor due to wave from external forcing - tauoc_wave(:,:) = sf_tauoc(1)%fnow(:,:,1) * tmask(:,:,1) + tauoc_wave(:,:) = sf_tauoc(1)%fnow(:,:,1) * smask0(:,:) ELSEIF ( ln_taw .AND. cpl_taw ) THEN IF (kt < 1) THEN ! The first fields gave by OASIS have very high erroneous values .... twox(:,:)=0._wp @@ -315,7 +319,7 @@ CONTAINS ! coupling routines IF( ln_zdfswm .AND. .NOT. cpl_wnum ) THEN !==wavenumber==! CALL fld_read( kt, nn_fsbc, sf_wn ) ! read wave parameters from external forcing - wnum(:,:) = sf_wn(1)%fnow(:,:,1) * tmask(:,:,1) + wnum(:,:) = sf_wn(1)%fnow(:,:,1) * smask0(:,:) ENDIF ! @@ -391,10 +395,10 @@ CONTAINS ! !== Allocate wave arrays ==! ALLOCATE( ut0sd (jpi,jpj) , vt0sd (jpi,jpj) ) ALLOCATE( hsw (jpi,jpj) , wmp (jpi,jpj) ) - ALLOCATE( wnum (jpi,jpj) ) ALLOCATE( tsd2d (jpi,jpj) , div_sd(jpi,jpj) , bhd_wave(jpi,jpj) ) ALLOCATE( usd (jpi,jpj,jpk), vsd (jpi,jpj,jpk), wsd (jpi,jpj,jpk) ) - ALLOCATE( tusd (jpi,jpj) , tvsd (jpi,jpj) , ZMX (jpi,jpj,jpk) ) + ALLOCATE( tusd (jpi,jpj) , tvsd (jpi,jpj) ) + ALLOCATE( wnum (A2D(0)) , ZMX (A2D(0),jpk) ) usd (:,:,:) = 0._wp vsd (:,:,:) = 0._wp wsd (:,:,:) = 0._wp @@ -422,30 +426,30 @@ CONTAINS ALLOCATE( sf_cd(1), STAT=ierror ) !* allocate and fill sf_wave with sn_cdg IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) ! - ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1) ) - IF( sn_cdg%ln_tint ) ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf_cd(1)%fnow(A2D(0),1) ) + IF( sn_cdg%ln_tint ) ALLOCATE( sf_cd(1)%fdta(A2D(0),1,2) ) CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) ENDIF - ALLOCATE( cdn_wave(jpi,jpj) ) + ALLOCATE( cdn_wave(A2D(0)) ) cdn_wave(:,:) = 0._wp ENDIF IF( ln_charn ) THEN ! wave drag IF( .NOT. cpl_charn ) THEN CALL ctl_stop( 'STOP', 'Charnock based wind stress can be used in coupled mode only' ) ENDIF - ALLOCATE( charn(jpi,jpj) ) + ALLOCATE( charn(A2D(0)) ) charn(:,:) = 0._wp ENDIF IF( ln_taw ) THEN ! wind stress IF( .NOT. cpl_taw ) THEN CALL ctl_stop( 'STOP', 'wind stress from wave model can be used in coupled mode only, use ln_cdgw instead' ) ENDIF - ALLOCATE( tawx(jpi,jpj) ) - ALLOCATE( tawy(jpi,jpj) ) - ALLOCATE( twox(jpi,jpj) ) - ALLOCATE( twoy(jpi,jpj) ) - ALLOCATE( tauoc_wavex(jpi,jpj) ) - ALLOCATE( tauoc_wavey(jpi,jpj) ) + ALLOCATE( tawx(A2D(0)) ) + ALLOCATE( tawy(A2D(0)) ) + ALLOCATE( twox(A2D(0)) ) + ALLOCATE( twoy(A2D(0)) ) + ALLOCATE( tauoc_wavex(A2D(0)) ) + ALLOCATE( tauoc_wavey(A2D(0)) ) tawx(:,:) = 0._wp tawy(:,:) = 0._wp twox(:,:) = 0._wp @@ -458,7 +462,7 @@ CONTAINS IF( .NOT. cpl_phioc ) THEN CALL ctl_stop( 'STOP', 'phioc can be used in coupled mode only' ) ENDIF - ALLOCATE( phioc(jpi,jpj) ) + ALLOCATE( phioc(A2D(0)) ) phioc(:,:) = 0._wp ENDIF @@ -467,11 +471,11 @@ CONTAINS ALLOCATE( sf_tauoc(1), STAT=ierror ) !* allocate and fill sf_wave with sn_tauoc IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauoc structure' ) ! - ALLOCATE( sf_tauoc(1)%fnow(jpi,jpj,1) ) - IF( sn_tauoc%ln_tint ) ALLOCATE( sf_tauoc(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf_tauoc(1)%fnow(A2D(0),1) ) + IF( sn_tauoc%ln_tint ) ALLOCATE( sf_tauoc(1)%fdta(A2D(0),1,2) ) CALL fld_fill( sf_tauoc, (/ sn_tauoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) ENDIF - ALLOCATE( tauoc_wave(jpi,jpj) ) + ALLOCATE( tauoc_wave(A2D(0)) ) tauoc_wave(:,:) = 0._wp ENDIF @@ -518,8 +522,8 @@ CONTAINS IF( .NOT. cpl_wnum ) THEN ALLOCATE( sf_wn(1), STAT=ierror ) !* allocate and fill sf_wave with sn_wnum IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wn structure' ) - ALLOCATE( sf_wn(1)%fnow(jpi,jpj,1) ) - IF( sn_wnum%ln_tint ) ALLOCATE( sf_wn(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf_wn(1)%fnow(A2D(0),1) ) + IF( sn_wnum%ln_tint ) ALLOCATE( sf_wn(1)%fdta(A2D(0),1,2) ) CALL fld_fill( sf_wn, (/ sn_wnum /), cn_dir, 'sbc_wave', 'Wave module', 'namsbc_wave' ) ENDIF ! diff --git a/src/OCE/TRA/eosbn2.F90 b/src/OCE/TRA/eosbn2.F90 index 1f808dfb94818f4a74df93d894748d087f296f98..5a04a3ca0b8454f1690306ccdd8d421d9973b8e3 100644 --- a/src/OCE/TRA/eosbn2.F90 +++ b/src/OCE/TRA/eosbn2.F90 @@ -83,9 +83,11 @@ MODULE eosbn2 INTEGER , PARAMETER :: np_teos10 = -1 ! parameter for using TEOS10 INTEGER , PARAMETER :: np_eos80 = 0 ! parameter for using EOS80 - INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state + INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state ! !!! simplified eos coefficients (default value: Vallis 2006) + REAL(wp), PUBLIC :: rn_T0 = 10._wp ! reference temperature + REAL(wp), PUBLIC :: rn_S0 = 35._wp ! reference salinity REAL(wp), PUBLIC :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. REAL(wp), PUBLIC :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 @@ -272,8 +274,8 @@ CONTAINS CASE( np_seos ) !== simplified EOS ==! ! DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem,Knn) - 10._wp - zs = pts (ji,jj,jk,jp_sal,Knn) - 35._wp + zt = pts (ji,jj,jk,jp_tem,Knn) - rn_T0 + zs = pts (ji,jj,jk,jp_sal,Knn) - rn_S0 zh = gdept(ji,jj,jk,Knn) ztm = tmask(ji,jj,jk) ! @@ -391,8 +393,8 @@ CONTAINS CASE( np_seos ) !== simplified EOS ==! ! DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem) - 10._wp - zs = pts (ji,jj,jk,jp_sal) - 35._wp + zt = pts (ji,jj,jk,jp_tem) - rn_T0 + zs = pts (ji,jj,jk,jp_sal) - rn_S0 zh = pdep (ji,jj,jk) ztm = tmask(ji,jj,jk) ! @@ -556,8 +558,8 @@ CONTAINS CASE( np_seos ) !== simplified EOS ==! ! DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem) - 10._wp - zs = pts (ji,jj,jk,jp_sal) - 35._wp + zt = pts (ji,jj,jk,jp_tem) - rn_T0 + zs = pts (ji,jj,jk,jp_sal) - rn_S0 zh = pdep (ji,jj,jk) ztm = tmask(ji,jj,jk) ! ! potential density referenced at the surface @@ -658,8 +660,8 @@ CONTAINS ! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! - zt = pts (ji,jj,jp_tem) - 10._wp - zs = pts (ji,jj,jp_sal) - 35._wp + zt = pts (ji,jj,jp_tem) - rn_T0 + zs = pts (ji,jj,jp_sal) - rn_S0 zh = pdep (ji,jj) ! depth at the partial step level ! zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & @@ -742,8 +744,8 @@ CONTAINS CASE( np_seos ) !== simplified EOS ==! ! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - zt = pts (ji,jj,jp_tem) - 10._wp - zs = pts (ji,jj,jp_sal) - 35._wp + zt = pts (ji,jj,jp_tem) - rn_T0 + zs = pts (ji,jj,jp_sal) - rn_S0 ztm = tmask(ji,jj,1) ! ! potential density referenced at the surface zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & @@ -853,9 +855,9 @@ CONTAINS CASE( np_seos ) !== simplified EOS ==! ! DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) - zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) - zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point + zt = pts (ji,jj,jk,jp_tem) - rn_T0 ! pot. temperature anomaly (t-T0) + zs = pts (ji,jj,jk,jp_sal) - rn_S0 ! abs. salinity anomaly (s-S0) + zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask ! zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs @@ -973,9 +975,9 @@ CONTAINS ! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! - zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) - zs = pts (ji,jj,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) - zh = pdep (ji,jj) ! depth at the partial step level + zt = pts (ji,jj,jp_tem) - rn_T0 ! pot. temperature anomaly (t-T0) + zs = pts (ji,jj,jp_sal) - rn_S0 ! abs. salinity anomaly (s-S0) + zh = pdep (ji,jj) ! depth at the partial step level ! zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs pab(ji,jj,jp_tem) = zn * r1_rho0 ! alpha @@ -1075,9 +1077,9 @@ CONTAINS ! CASE( np_seos ) !== simplified EOS ==! ! - zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) - zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) - zh = pdep ! depth at the partial step level + zt = pts(jp_tem) - rn_T0 ! pot. temperature anomaly (t-T0) + zs = pts(jp_sal) - rn_S0 ! abs. salinity anomaly (s-S0) + zh = pdep ! depth at the partial step level ! zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs pab(jp_tem) = zn * r1_rho0 ! alpha @@ -1164,28 +1166,37 @@ CONTAINS !! Reference : TEOS-10, UNESCO !! Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC) !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celsius] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] + REAL(wp), DIMENSION(:,:), INTENT(in ) :: ctmp ! Cons. Temp [Celsius] + REAL(wp), DIMENSION(:,:), INTENT(in ) :: psal ! salinity [psu] ! Leave result array automatic rather than making explicitly allocated - REAL(wp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celsius] + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ptmp ! potential temperature [Celsius] ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zt , zs , ztm ! local scalars REAL(wp) :: zn , zd ! local scalars REAL(wp) :: zdeltaS , z1_S0 , z1_T0 + INTEGER :: ipi, ipj, iisht, ijsht ! dimensions and shift indices !!---------------------------------------------------------------------- ! + ipi = SIZE(psal,1) ! 1st dimension + ipj = SIZE(psal,2) ! 2nd dimension + ! + iisht = ( jpi - ipi ) / 2 + ijsht = ( jpj - ipj ) / 2 ! should be the same as iisht... + ! + IF( .NOT.ALLOCATED(ptmp) ) ALLOCATE( ptmp(ipi,ipj) ) + ! IF( ln_timing ) CALL timing_start('eos_pt_from_ct') ! zdeltaS = 5._wp z1_S0 = 0.875_wp/35.16504_wp z1_T0 = 1._wp/40._wp ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( nn_hls-iisht, nn_hls-iisht, nn_hls-ijsht, nn_hls-ijsht ) ! - zt = ctmp (ji,jj) * z1_T0 - zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * z1_S0 ) - ztm = tmask(ji,jj,1) + zt = ctmp (ji-iisht,jj-ijsht) * z1_T0 + zs = SQRT( ABS( psal(ji-iisht,jj-ijsht) + zdeltaS ) * z1_S0 ) + ztm = tmask(ji-iisht,jj-ijsht,1) ! zn = ((((-2.1385727895e-01_wp*zt & & - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt & @@ -1200,7 +1211,7 @@ CONTAINS & -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt & & + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp ! - ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm + ptmp(ji-iisht,jj-ijsht) = ( zt / z1_T0 + zn / zd ) * ztm ! END_2D ! @@ -1211,9 +1222,9 @@ CONTAINS SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) !! - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] - REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius] + REAL(wp), DIMENSION(:,:), INTENT(in ) :: psal ! salinity [psu] + REAL(wp), DIMENSION(:,:), INTENT(in ), OPTIONAL :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:), INTENT(out ) :: ptf ! freezing temperature [Celsius] !! CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) END SUBROUTINE eos_fzp_2d @@ -1231,35 +1242,52 @@ CONTAINS !! !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kttf - REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu] - REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ), OPTIONAL :: pdep ! depth [m] - REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius] + INTEGER , INTENT(in ) :: kttf + REAL(wp), DIMENSION(:,:), INTENT(in ) :: psal ! salinity [psu] + REAL(wp), DIMENSION(:,:), INTENT(in ), OPTIONAL :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:), INTENT(out ) :: ptf ! freezing temperature [Celsius] ! INTEGER :: ji, jj ! dummy loop indices REAL(wp) :: zt, zs, z1_S0 ! local scalars + INTEGER :: ipi, ipj, iisht, ijsht ! dimensions and shift indices !!---------------------------------------------------------------------- ! + ipi = SIZE(psal,1) ! 1st dimension + ipj = SIZE(psal,2) ! 2nd dimension + ! + iisht = ( jpi - ipi ) / 2 + ijsht = ( jpj - ipj ) / 2 ! should be the same as iisht... + ! SELECT CASE ( neos ) ! CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==! ! z1_S0 = 1._wp / 35.16504_wp - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 ) ! square root salinity - ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & - & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp + DO_2D( nn_hls-iisht, nn_hls-iisht, nn_hls-ijsht, nn_hls-ijsht ) + zs= SQRT( ABS( psal(ji-iisht,jj-ijsht) ) * z1_S0 ) ! square root salinity + ptf(ji-iisht,jj-ijsht) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & + & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp + ptf(ji-iisht,jj-ijsht) = ptf(ji-iisht,jj-ijsht) * psal(ji-iisht,jj-ijsht) END_2D - ptf(:,:) = ptf(:,:) * psal(:,:) ! - IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) + IF( PRESENT( pdep ) ) THEN + DO_2D( nn_hls-iisht, nn_hls-iisht, nn_hls-ijsht, nn_hls-ijsht ) + ptf(ji-iisht,jj-ijsht) = ptf(ji-iisht,jj-ijsht) - 7.53e-4 * pdep(ji-iisht,jj-ijsht) + END_2D + ENDIF ! CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! ! - ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) & - & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:) - ! - IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) + DO_2D( nn_hls-iisht, nn_hls-iisht, nn_hls-ijsht, nn_hls-ijsht ) + ptf(ji-iisht,jj-ijsht) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(ji-iisht,jj-ijsht) ) & + & - 2.154996e-4_wp * psal(ji-iisht,jj-ijsht) ) * psal(ji-iisht,jj-ijsht) + END_2D + ! + IF( PRESENT( pdep ) ) THEN + DO_2D( nn_hls-iisht, nn_hls-iisht, nn_hls-ijsht, nn_hls-ijsht ) + ptf(ji-iisht,jj-ijsht) = ptf(ji-iisht,jj-ijsht) - 7.53e-4 * pdep(ji-iisht,jj-ijsht) + END_2D + ENDIF ! CASE DEFAULT WRITE(ctmp1,*) ' bad flag value for neos = ', neos @@ -1412,10 +1440,10 @@ CONTAINS CASE( np_seos ) !== Vallis (2006) simplified EOS ==! ! DO_3D( 0, 0, 0, 0, 1, jpkm1 ) - zt = pts(ji,jj,jk,jp_tem) - 10._wp ! temperature anomaly (t-T0) - zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) - zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point - ztm = tmask(ji,jj,jk) ! tmask + zt = pts (ji,jj,jk,jp_tem) - rn_T0 ! temperature anomaly (t-T0) + zs = pts (ji,jj,jk,jp_sal) - rn_S0 ! abs. salinity anomaly (s-S0) + zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point + ztm = tmask(ji,jj,jk) ! tmask zn = 0.5_wp * zh * r1_rho0 * ztm ! ! Potential Energy ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn @@ -1447,8 +1475,8 @@ CONTAINS INTEGER :: ios ! local integer INTEGER :: ioptio ! local integer !! - NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, rn_a0, rn_b0, rn_lambda1, rn_mu1, & - & rn_lambda2, rn_mu2, rn_nu + NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, rn_T0, rn_S0, rn_a0, rn_b0, rn_lambda1, rn_mu1, & + & rn_lambda2, rn_mu2, rn_nu !!---------------------------------------------------------------------- ! READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) @@ -1869,9 +1897,11 @@ CONTAINS IF(lwp) THEN WRITE(numout,*) WRITE(numout,*) ' ==>>> use of simplified eos: ' - WRITE(numout,*) ' rhd(dT=T-10,dS=S-35,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT ' - WRITE(numout,*) ' + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rho0' + WRITE(numout,*) ' rhd(dT=T-rn_T0,dS=S-rn_S0,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT ' + WRITE(numout,*) ' + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rho0' WRITE(numout,*) ' with the following coefficients :' + WRITE(numout,*) ' reference temperature rn_T0 = ', rn_T0 + WRITE(numout,*) ' reference salinity rn_S0 = ', rn_S0 WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0 WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0 WRITE(numout,*) ' cabbeling coef. rn_lambda1 = ', rn_lambda1 diff --git a/src/OCE/TRA/traatf.F90 b/src/OCE/TRA/traatf.F90 index 57a9ca0a47851146bcfd09c7a769c70ad6a69663..ec745d779916e30f0ebbeeb51714683d427d662a 100644 --- a/src/OCE/TRA/traatf.F90 +++ b/src/OCE/TRA/traatf.F90 @@ -207,7 +207,7 @@ CONTAINS ! DO jn = 1, kjpt ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ztn = pt(ji,jj,jk,jn,Kmm) ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers ! @@ -238,8 +238,8 @@ CONTAINS CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields - REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content - REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content + REAL(wp), DIMENSION(A2D(0) ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content + REAL(wp), DIMENSION(A2D(0) ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content ! LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical INTEGER :: ji, jj, jk, jn ! dummy loop indices @@ -269,14 +269,11 @@ CONTAINS ztrd_atf(:,:,:,:) = 0.0_wp ENDIF ! -!!st variables only computed in the interior by traqsr - IF( ll_traqsr ) CALL lbc_lnk( 'traatf', qsr_hc_b(:,:,:) , 'T', 1.0_wp, qsr_hc(:,:,:) , 'T', 1.0_wp ) - ! zfact = 1._wp / p2dt zfact1 = rn_atfp * p2dt zfact2 = zfact1 * r1_rho0 DO jn = 1, kjpt - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ze3t_b = e3t(ji,jj,jk,Kbb) ze3t_n = e3t(ji,jj,jk,Kmm) ze3t_a = e3t(ji,jj,jk,Kaa) diff --git a/src/OCE/TRA/traatf_qco.F90 b/src/OCE/TRA/traatf_qco.F90 index 57034bd06088f54863e35898473f9a6c64f2323a..5563febbee37c5a28cd2212924c9d5cab64d8d4a 100644 --- a/src/OCE/TRA/traatf_qco.F90 +++ b/src/OCE/TRA/traatf_qco.F90 @@ -150,7 +150,7 @@ CONTAINS ELSE ; CALL tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, nit000, rn_Dt, 'TRA', pts, sbc_tsc, sbc_tsc_b, jpts ) ! non-linear free surface ENDIF ! - CALL lbc_lnk( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp ) + CALL lbc_lnk( 'traatf_qco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp ) ! ENDIF ! @@ -203,7 +203,6 @@ CONTAINS DO jn = 1, kjpt ! DO_3D( 0, 0, 0, 0, 1, jpkm1 ) -!!st DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) ztn = pt(ji,jj,jk,jn,Kmm) ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers ! @@ -234,8 +233,8 @@ CONTAINS CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields - REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content - REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content + REAL(wp), DIMENSION(A2D(0) ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content + REAL(wp), DIMENSION(A2D(0) ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content ! LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical INTEGER :: ji, jj, jk, jn ! dummy loop indices @@ -264,12 +263,12 @@ CONTAINS ALLOCATE( ztrd_atf(jpi,jpj,jpk,kjpt) ) ztrd_atf(:,:,:,:) = 0._wp ENDIF + ! zfact = 1._wp / p2dt zfact1 = rn_atfp * p2dt zfact2 = zfact1 * r1_rho0 DO jn = 1, kjpt DO_3D( 0, 0, 0, 0, 1, jpkm1 ) -!!st DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) ze3t_b = e3t(ji,jj,jk,Kbb) ze3t_n = e3t(ji,jj,jk,Kmm) ze3t_a = e3t(ji,jj,jk,Kaa) diff --git a/src/OCE/TRA/trasbc.F90 b/src/OCE/TRA/trasbc.F90 index 0f8472a324a1753f8c1f128f1bd28e339a297643..b0cc6580bf3bd35a6f1a961bcaff4207fdc89f51 100644 --- a/src/OCE/TRA/trasbc.F90 +++ b/src/OCE/TRA/trasbc.F90 @@ -100,7 +100,7 @@ CONTAINS ! !!gm This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) IF( .NOT.ln_traqsr ) THEN ! no solar radiation penetration - DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D_OVR( 0, 0, 0, 0 ) qns(ji,jj) = qns(ji,jj) + qsr(ji,jj) ! total heat flux in qns qsr(ji,jj) = 0._wp ! qsr set to zero END_2D @@ -121,24 +121,24 @@ CONTAINS ENDIF ELSE ! No restart or restart not found: Euler forward time stepping zfact = 1._wp - DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D_OVR( 0, 0, 0, 0 ) sbc_tsc(ji,jj,:) = 0._wp sbc_tsc_b(ji,jj,:) = 0._wp END_2D ENDIF ELSE !* other time-steps: swap of forcing fields zfact = 0.5_wp - DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D_OVR( 0, 0, 0, 0 ) sbc_tsc_b(ji,jj,:) = sbc_tsc(ji,jj,:) END_2D ENDIF ! !== Now sbc tracer content fields ==! - DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D_OVR( 0, 0, 0, 0 ) sbc_tsc(ji,jj,jp_tem) = r1_rho0_rcp * qns(ji,jj) ! non solar heat flux sbc_tsc(ji,jj,jp_sal) = r1_rho0 * sfx(ji,jj) ! salt flux due to freezing/melting END_2D IF( ln_linssh ) THEN !* linear free surface - DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) !==>> add concentration/dilution effect due to constant volume cell + DO_2D_OVR( 0, 0, 0, 0 ) !==>> add concentration/dilution effect due to constant volume cell sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) END_2D !==>> output c./d. term @@ -275,7 +275,7 @@ CONTAINS !!gm This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) IF( .NOT.ln_traqsr .AND. kstg == 1) THEN ! no solar radiation penetration - DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D_OVR( 0, 0, 0, 0 ) qns(ji,jj) = qns(ji,jj) + qsr(ji,jj) ! total heat flux in qns qsr(ji,jj) = 0._wp ! qsr set to zero END_2D diff --git a/src/OCE/TRA/trazdf.F90 b/src/OCE/TRA/trazdf.F90 index 8280d3181b6b2731e8616a0a24a938bd15b4d759..6e7dd9a249bebc44102a67bf2ff140da9282c1de 100644 --- a/src/OCE/TRA/trazdf.F90 +++ b/src/OCE/TRA/trazdf.F90 @@ -146,7 +146,7 @@ CONTAINS ! INTEGER :: ji, jj, jk, jn ! dummy loop indices REAL(wp) :: zrhs, zzwi, zzws ! local scalars - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwt, zwd, zws + REAL(wp), DIMENSION(A2D(0),jpk) :: zwi, zwt, zwd, zws !!--------------------------------------------------------------------- ! ! ! ============= ! @@ -161,11 +161,11 @@ CONTAINS ! ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN - DO_3D( 1, 1, 1, 1, 2, jpk ) + DO_3D( 0, 0, 0, 0, 2, jpk ) zwt(ji,jj,jk) = avt(ji,jj,jk) END_3D ELSE - DO_3D( 1, 1, 1, 1, 2, jpk ) + DO_3D( 0, 0, 0, 0, 2, jpk ) zwt(ji,jj,jk) = avs(ji,jj,jk) END_3D ENDIF diff --git a/src/OCE/USR/usrdef_sbc.F90 b/src/OCE/USR/usrdef_sbc.F90 index 2af3f30d2789fe3cfafadda55d4141c9c38c95b8..0be3bd7e98fc014cf9ae38301933a870dcb89998 100644 --- a/src/OCE/USR/usrdef_sbc.F90 +++ b/src/OCE/USR/usrdef_sbc.F90 @@ -109,7 +109,7 @@ CONTAINS ztrp= - 40.e0 ! retroaction term on heat fluxes (W/m2/K) zconv = 3.16e-5 ! convertion factor: 1 m/yr => 3.16e-5 mm/s - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! emp and rnf used in sshwzv over the whole domain + DO_2D( 0, 0, 0, 0 ) ! domain from 15 deg to 50 deg between 27 and 28 degC at 15N, -3 ! and 13 degC at 50N 53.5 + or - 11 = 1/4 period : ! 64.5 in summer, 42.5 in winter @@ -119,6 +119,8 @@ CONTAINS ! 23.5 deg : tropics qsr (ji,jj) = 230 * COS( 3.1415 * ( gphit(ji,jj) - 23.5 * zcos_sais1 ) / ( 0.9 * 180 ) ) qns (ji,jj) = ztrp * ( ts(ji,jj,1,jp_tem,Kbb) - t_star ) - qsr(ji,jj) + END_2D + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! emp and rnf used in sshwzv over the whole domain IF( gphit(ji,jj) >= 14.845 .AND. 37.2 >= gphit(ji,jj) ) THEN ! zero at 37.8 deg, max at 24.6 deg emp (ji,jj) = zemp_S * zconv & & * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (24.6 - 37.2) ) & @@ -137,6 +139,8 @@ CONTAINS ! freshwater (mass flux) and update of qns with heat content of emp DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! emp used in sshwzv over the whole domain emp (ji,jj) = emp(ji,jj) - zsumemp * tmask(ji,jj,1) ! freshwater flux (=0 in domain average) + END_2D + DO_2D( 0, 0, 0, 0 ) sfx (ji,jj) = 0.0_wp ! no salt flux qns (ji,jj) = qns(ji,jj) - emp(ji,jj) * sst_m(ji,jj) * rcp ! evap and precip are at SST END_2D @@ -175,7 +179,7 @@ CONTAINS ! module of wind stress and wind speed at T-point zcoef = 1. / ( zrhoa * zcdrag ) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zmod = SQRT( utau(ji,jj) * utau(ji,jj) + vtau(ji,jj) * vtau(ji,jj) ) taum(ji,jj) = zmod wndm(ji,jj) = SQRT( zmod * zcoef ) diff --git a/src/OCE/ZDF/zdf_oce.F90 b/src/OCE/ZDF/zdf_oce.F90 index 40bcb56ce9b07a1c3ac51ffd51d45f310e0c64fa..bb470370d8c0ad72b2ae89d8a11e3a499cdb274b 100644 --- a/src/OCE/ZDF/zdf_oce.F90 +++ b/src/OCE/ZDF/zdf_oce.F90 @@ -53,6 +53,8 @@ MODULE zdf_oce REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: avmb , avtb !: background profile of avm and avt [m2/s] REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: avtb_2d !: horizontal shape of background Kz profile [-] + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) !! $Id: zdf_oce.F90 14072 2020-12-04 07:48:38Z laurent $ @@ -65,9 +67,9 @@ CONTAINS !! *** FUNCTION zdf_oce_alloc *** !!---------------------------------------------------------------------- ! - ALLOCATE( avm (jpi,jpj,jpk) , avm_k(jpi,jpj,jpk) , avs(jpi,jpj,jpk) , & - & avt (jpi,jpj,jpk) , avt_k(jpi,jpj,jpk) , en (jpi,jpj,jpk) , & - & avmb(jpk) , avtb(jpk) , avtb_2d(jpi,jpj) , STAT = zdf_oce_alloc ) + ALLOCATE( avm (jpi,jpj,jpk) , avm_k(jpi,jpj,jpk) , avs(A2D(0),jpk) , & + & avt (A2D(0) ,jpk) , avt_k(A2D(0) ,jpk) , en (A2D(0),jpk) , & + & avmb(jpk) , avtb(jpk) , avtb_2d(A2D(0)) , STAT = zdf_oce_alloc ) ! IF( zdf_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_oce_alloc: failed to allocate arrays' ) ! diff --git a/src/OCE/ZDF/zdfddm.F90 b/src/OCE/ZDF/zdfddm.F90 index a08cf3439b254cff6f6864f7eee3f7052aed3ae6..3004091bbada80c8b929f2f56567384f61c5350a 100644 --- a/src/OCE/ZDF/zdfddm.F90 +++ b/src/OCE/ZDF/zdfddm.F90 @@ -70,9 +70,9 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: kt ! ocean time-step index INTEGER, INTENT(in ) :: Kmm ! ocean time level index - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm ! Kz on momentum (w-points) - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avt ! Kz on temperature (w-points) - REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avs ! Kz on salinity (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! Kz on momentum (w-points) + REAL(wp), DIMENSION(A2D(0),jpk), INTENT(inout) :: p_avt ! Kz on temperature (w-points) + REAL(wp), DIMENSION(A2D(0),jpk), INTENT( out) :: p_avs ! Kz on salinity (w-points) ! INTEGER :: ji, jj , jk ! dummy loop indices REAL(wp) :: zaw, zbw, zrw ! local scalars @@ -82,7 +82,7 @@ CONTAINS REAL(wp) :: zavft ! - - REAL(dp) :: zavfs ! - - REAL(wp) :: zavdt, zavds ! - - - REAL(wp), DIMENSION(A2D(nn_hls)) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 + REAL(wp), DIMENSION(A2D(0)) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 !!---------------------------------------------------------------------- ! ! ! =============== @@ -94,7 +94,7 @@ CONTAINS !!gm ==>>> test in the loop instead of use of mask arrays !!gm and many acces in memory - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==! + DO_2D( 0, 0, 0, 0 ) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==! zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & !!gm please, use e3w at Kmm below & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) ) @@ -110,7 +110,7 @@ CONTAINS zrau(ji,jj) = MAX( 1.e-20, zdt / zds ) ! only retains positive value of zrau END_2D - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !== indicators ==! + DO_2D( 0, 0, 0, 0 ) !== indicators ==! ! stability indicator: msks=1 if rn2>0; 0 elsewhere IF( rn2(ji,jj,jk) + 1.e-12 <= 0. ) THEN ; zmsks(ji,jj) = 0._wp ELSE ; zmsks(ji,jj) = 1._wp * wmask(ji,jj,jk) ! mask so avt and avs masked @@ -137,7 +137,7 @@ CONTAINS ! Update avt and avs ! ------------------ ! Constant eddy coefficient: reset to the background value - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) zinr = 1._wp / zrau(ji,jj) ! salt fingering zrr = zrau(ji,jj) / rn_hsbfr diff --git a/src/OCE/ZDF/zdfevd.F90 b/src/OCE/ZDF/zdfevd.F90 index df8bfeaa5b701b30b19d265031f0b0732d803bac..6d821700029b0048aefb6f55417cde387797dd0b 100644 --- a/src/OCE/ZDF/zdfevd.F90 +++ b/src/OCE/ZDF/zdfevd.F90 @@ -56,9 +56,10 @@ CONTAINS !! !! ** Action : avt, avm enhanced where static instability occurs !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! ocean time-step indexocean time step - INTEGER , INTENT(in ) :: Kmm, Krhs ! time level indices - REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + INTEGER , INTENT(in ) :: kt ! ocean time-step indexocean time step + INTEGER , INTENT(in ) :: Kmm, Krhs ! time level indices + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(A2D(0),jpk), INTENT(inout) :: p_avt ! tracer Kz (w-points) ! INTEGER :: ji, jj, jk ! dummy loop indices ! NOTE: [tiling] use a SAVE array to store diagnostics, then send after all tiles are finished. This is necessary because p_avt/p_avm are modified on adjacent tiles when using nn_hls > 1. zavt_evd/zavm_evd are then zero on some points when subsequently calculated for these tiles. @@ -73,12 +74,12 @@ CONTAINS IF(lwp) WRITE(numout,*) ENDIF - ALLOCATE( zavt_evd(jpi,jpj,jpk) ) - IF( nn_evdm == 1 ) ALLOCATE( zavm_evd(jpi,jpj,jpk) ) + ALLOCATE( zavt_evd(A2D(0),jpk) ) + IF( nn_evdm == 1 ) ALLOCATE( zavm_evd(A2D(0),jpk) ) ENDIF ! ! - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpk ) zavt_evd(ji,jj,jk) = p_avt(ji,jj,jk) ! set avt prior to evd application END_3D ! @@ -86,7 +87,7 @@ CONTAINS ! CASE ( 1 ) !== enhance tracer & momentum Kz ==! (if rn2<-1.e-12) ! - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpk ) zavm_evd(ji,jj,jk) = p_avm(ji,jj,jk) ! set avm prior to evd application END_3D ! @@ -96,14 +97,14 @@ CONTAINS ! p_avm(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1) ! END WHERE ! - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpkm1 ) IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) THEN p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk) p_avm(ji,jj,jk) = rn_evd * wmask(ji,jj,jk) ENDIF END_3D ! - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpk ) zavm_evd(ji,jj,jk) = p_avm(ji,jj,jk) - zavm_evd(ji,jj,jk) ! change in avm due to evd END_3D IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile @@ -117,14 +118,14 @@ CONTAINS ! p_avt(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1) ! END WHERE - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpkm1 ) IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) & p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk) END_3D ! END SELECT ! - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpk ) zavt_evd(ji,jj,jk) = p_avt(ji,jj,jk) - zavt_evd(ji,jj,jk) ! change in avt due to evd END_3D ! diff --git a/src/OCE/ZDF/zdfgls.F90 b/src/OCE/ZDF/zdfgls.F90 index b25670799dae097c9853dfdda687a3743aeea10a..f44ccc814faf6b6e84f425af23e6f0dfbb449c5c 100644 --- a/src/OCE/ZDF/zdfgls.F90 +++ b/src/OCE/ZDF/zdfgls.F90 @@ -126,8 +126,8 @@ CONTAINS !!---------------------------------------------------------------------- !! *** FUNCTION zdf_gls_alloc *** !!---------------------------------------------------------------------- - ALLOCATE( hmxl_n(jpi,jpj,jpk) , ustar2_surf(jpi,jpj) , & - & zwall (jpi,jpj,jpk) , ustar2_top (jpi,jpj) , ustar2_bot(jpi,jpj) , STAT= zdf_gls_alloc ) + ALLOCATE( hmxl_n(A2D(0),jpk) , ustar2_surf(A2D(0)) , & + & zwall (A2D(0),jpk) , ustar2_top (A2D(0)) , ustar2_bot(A2D(0)) , STAT= zdf_gls_alloc ) ! CALL mpp_sum ( 'zdfgls', zdf_gls_alloc ) IF( zdf_gls_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_gls_alloc: failed to allocate arrays' ) @@ -143,10 +143,11 @@ CONTAINS !!---------------------------------------------------------------------- USE zdf_oce , ONLY : en, avtb, avmb ! ocean vertical physics !! - INTEGER , INTENT(in ) :: kt ! ocean time step - INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term - REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(A2D(0),jpk), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(A2D(0),jpk), INTENT(inout) :: p_avt ! tracer Kz (w-points) ! INTEGER :: ji, jj, jk ! dummy loop arguments INTEGER :: ibot, ibotm1 ! local integers @@ -157,51 +158,51 @@ CONTAINS REAL(wp) :: prod, buoy, diss, zdiss, sm ! - - REAL(wp) :: gh, gm, shr, dif, zsqen, zavt, zavm ! - - REAL(wp) :: zmsku, zmskv ! - - - REAL(wp), DIMENSION(A2D(nn_hls)) :: zdep - REAL(wp), DIMENSION(A2D(nn_hls)) :: zkar - REAL(wp), DIMENSION(A2D(nn_hls)) :: zflxs ! Turbulence fluxed induced by internal waves - REAL(wp), DIMENSION(A2D(nn_hls)) :: zhsro ! Surface roughness (surface waves) - REAL(wp), DIMENSION(A2D(nn_hls)) :: zice_fra ! Tapering of wave breaking under sea ice - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: eb ! tke at time before - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: hmxl_b ! mixing length at time before - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: eps ! dissipation rate - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwall_psi ! Wall function use in the wb case (ln_sigpsi) - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: psi ! psi at time now - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zd_lw, zd_up, zdiag ! lower, upper and diagonal of the matrix - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zstt, zstm ! stability function on tracer and momentum + REAL(wp), DIMENSION(A2D(0)) :: zdep + REAL(wp), DIMENSION(A2D(0)) :: zkar + REAL(wp), DIMENSION(A2D(0)) :: zflxs ! Turbulence fluxed induced by internal waves + REAL(wp), DIMENSION(A2D(0)) :: zhsro ! Surface roughness (surface waves) + REAL(wp), DIMENSION(A2D(0)) :: zice_fra ! Tapering of wave breaking under sea ice + REAL(wp), DIMENSION(A2D(0),jpk) :: eb ! tke at time before + REAL(wp), DIMENSION(A2D(0),jpk) :: hmxl_b ! mixing length at time before + REAL(wp), DIMENSION(A2D(0),jpk) :: eps ! dissipation rate + REAL(wp), DIMENSION(A2D(0),jpk) :: zwall_psi ! Wall function use in the wb case (ln_sigpsi) + REAL(wp), DIMENSION(A2D(0),jpk) :: psi ! psi at time now + REAL(wp), DIMENSION(A2D(0),jpk) :: zd_lw, zd_up, zdiag ! lower, upper and diagonal of the matrix + REAL(wp), DIMENSION(A2D(0),jpk) :: zstt, zstm ! stability function on tracer and momentum !!-------------------------------------------------------------------- ! ! Preliminary computing - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) ustar2_surf(ji,jj) = 0._wp ; ustar2_top(ji,jj) = 0._wp ; ustar2_bot(ji,jj) = 0._wp END_2D - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + DO_3D( 0, 0, 0, 0, 1, jpk ) psi(ji,jj,jk) = 0._wp ; zwall_psi(ji,jj,jk) = 0._wp END_3D SELECT CASE ( nn_z0_ice ) CASE( 0 ) ; zice_fra(:,:) = 0._wp - CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(A2D(nn_hls)) * 10._wp ) - CASE( 2 ) ; zice_fra(:,:) = fr_i(A2D(nn_hls)) - CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(A2D(nn_hls)) , 1._wp ) + CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(A2D(0)) * 10._wp ) + CASE( 2 ) ; zice_fra(:,:) = fr_i(A2D(0)) + CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(A2D(0)) , 1._wp ) END SELECT ! Compute surface, top and bottom friction at T-points - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !== surface ocean friction + DO_2D_OVR( 0, 0, 0, 0 ) !== surface ocean friction ustar2_surf(ji,jj) = r1_rho0 * taum(ji,jj) * tmask(ji,jj,1) ! surface friction END_2D ! !!gm Rq we may add here r_ke0(_top/_bot) ? ==>> think about that... ! IF( .NOT.ln_drg_OFF ) THEN !== top/bottom friction (explicit before friction) - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! bottom friction (explicit before friction) + DO_2D_OVR( 0, 0, 0, 0 ) ! bottom friction (explicit before friction) zmsku = 0.5_wp * ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) zmskv = 0.5_wp * ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) END_2D IF( ln_isfcav ) THEN - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! top friction + DO_2D_OVR( 0, 0, 0, 0 ) ! top friction zmsku = 0.5_wp * ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) zmskv = 0.5_wp * ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0) ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & @@ -214,57 +215,59 @@ CONTAINS CASE ( 0 ) ! Constant roughness zhsro(:,:) = rn_hsro CASE ( 1 ) ! Standard Charnock formula - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zhsro(ji,jj) = MAX( rsbc_zs1 * ustar2_surf(ji,jj) , rn_hsro ) END_2D CASE ( 2 ) ! Roughness formulae according to Rascle et al., Ocean Modelling (2008) !!gm faster coding : the 2 comment lines should be used !!gm zcof = 2._wp * 0.6_wp / 28._wp !!gm zdep(:,:) = 30._wp * TANH( zcof/ SQRT( MAX(ustar2_surf(:,:),rsmall) ) ) ! Wave age (eq. 10) - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zcof = 30.*TANH( 2.*0.3/(28.*SQRT(MAX(ustar2_surf(ji,jj),rsmall))) ) ! Wave age (eq. 10) zhsro(ji,jj) = MAX(rsbc_zs2 * ustar2_surf(ji,jj) * zcof**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11) END_2D CASE ( 3 ) ! Roughness given by the wave model (coupled or read in file) - zhsro(:,:) = MAX(rn_frac_hs * hsw(A2D(nn_hls)), rn_hsro) ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 ) + DO_2D( 0, 0, 0, 0 ) + zhsro(ji,jj) = MAX(rn_frac_hs * hsw(ji,jj), rn_hsro) ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 ) + END_2D END SELECT ! ! adapt roughness where there is sea ice SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice ! CASE( 1 ) ! scaling with constant sea-ice roughness - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * rn_hsri )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro END_2D ! CASE( 2 ) ! scaling with mean sea-ice thickness #if defined key_si3 - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * hm_i(ji,jj) )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro END_2D #endif ! CASE( 3 ) ! scaling with max sea-ice thickness #if defined key_si3 || defined key_cice - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * MAXVAL(h_i(ji,jj,:)) )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro END_2D #endif ! END SELECT ! - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !== Compute dissipation rate ==! + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== Compute dissipation rate ==! eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) END_3D ! Save tke at before time step - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + DO_3D( 0, 0, 0, 0, 1, jpk ) eb (ji,jj,jk) = en (ji,jj,jk) hmxl_b(ji,jj,jk) = hmxl_n(ji,jj,jk) END_3D IF( nn_clos == 0 ) THEN ! Mellor-Yamada - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) zup = hmxl_n(ji,jj,jk) * gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) zdown = vkarmn * gdepw(ji,jj,jk,Kmm) * ( -gdepw(ji,jj,jk,Kmm) + gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) ) zcoef = ( zup / MAX( zdown, rsmall ) ) @@ -285,7 +288,7 @@ CONTAINS ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal ! Warning : after this step, en : right hand side of the matrix - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) ! buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk) ! stratif. destruction ! @@ -326,7 +329,7 @@ CONTAINS en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zesh2 * wmask(ji,jj,jk) END_3D ! - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) zdiag(ji,jj,jpk) = 1._wp ! ! Set surface condition on zwall_psi (1 at the bottom) @@ -340,7 +343,7 @@ CONTAINS SELECT CASE ( nn_bc_surf ) ! CASE ( 0 ) ! Dirichlet boundary condition (set e at k=1 & 2) - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) ! First level en (ji,jj,1) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1)**r2_3 ) zd_lw(ji,jj,1) = en(ji,jj,1) @@ -356,7 +359,7 @@ CONTAINS END_2D ! IF( ln_isfcav) THEN ! top boundary (ocean cavity) - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) IF( mikt(ji,jj) > 1 )THEN itop = mikt(ji,jj) ! k top w-point itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one @@ -377,7 +380,7 @@ CONTAINS ! CASE ( 1 ) ! Neumann boundary condition (set d(e)/dz) ! - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) ! Dirichlet conditions at k=1 en (ji,jj,1) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1)**r2_3 ) zd_lw(ji,jj,1) = en(ji,jj,1) @@ -398,7 +401,7 @@ CONTAINS END_2D ! IF( ln_isfcav) THEN ! top boundary (ocean cavity) - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) IF( mikt(ji,jj) > 1 )THEN itop = mikt(ji,jj) ! k top w-point itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one @@ -428,7 +431,7 @@ CONTAINS CASE ( 0 ) ! Dirichlet ! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = rn_lmin ! ! Balance between the production and the dissipation terms - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) !!gm This means that bottom and ocean w-level above have a specified "en" value. Sure ???? !! With thick deep ocean level thickness, this may be quite large, no ??? !! in particular in ocean cavities where top stratification can be large... @@ -447,7 +450,7 @@ CONTAINS ! ! NOTE: ctl_stop with ln_isfcav when using GLS IF( ln_isfcav) THEN ! top boundary (ocean cavity) - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) itop = mikt(ji,jj) ! k top w-point itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one ! ! mask at the ocean surface points @@ -465,7 +468,7 @@ CONTAINS ! CASE ( 1 ) ! Neumman boundary condition ! - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 ! @@ -481,7 +484,7 @@ CONTAINS END_2D ! NOTE: ctl_stop with ln_isfcav when using GLS IF( ln_isfcav) THEN ! top boundary (ocean cavity) - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) itop = mikt(ji,jj) ! k top w-point itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one ! ! mask at the ocean surface points @@ -502,17 +505,17 @@ CONTAINS ! Matrix inversion (en prescribed at surface and the bottom) ! ---------------------------------------------------------- ! - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) END_3D - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) END_3D - DO_3DS_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + DO_3DS_OVR( 0, 0, 0, 0, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) END_3D ! ! set the minimum value of tke - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpk ) en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) END_3D @@ -525,22 +528,22 @@ CONTAINS SELECT CASE ( nn_clos ) ! CASE( 0 ) ! k-kl (Mellor-Yamada) - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) psi(ji,jj,jk) = eb(ji,jj,jk) * hmxl_b(ji,jj,jk) END_3D ! CASE( 1 ) ! k-eps - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) psi(ji,jj,jk) = eps(ji,jj,jk) END_3D ! CASE( 2 ) ! k-w - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) psi(ji,jj,jk) = SQRT( eb(ji,jj,jk) ) / ( rc0 * hmxl_b(ji,jj,jk) ) END_3D ! CASE( 3 ) ! generic - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) psi(ji,jj,jk) = rc02 * eb(ji,jj,jk) * hmxl_b(ji,jj,jk)**rnn END_3D ! @@ -553,7 +556,7 @@ CONTAINS ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal ! Warning : after this step, en : right hand side of the matrix - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! ! psi / k zratio = psi(ji,jj,jk) / eb(ji,jj,jk) @@ -591,7 +594,7 @@ CONTAINS psi(ji,jj,jk) = psi(ji,jj,jk) + rn_Dt * zesh2 * wmask(ji,jj,jk) END_3D ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zdiag(ji,jj,jpk) = 1._wp END_2D @@ -602,7 +605,7 @@ CONTAINS ! CASE ( 0 ) ! Dirichlet boundary conditions ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) ! Surface value zdep (ji,jj) = zhsro(ji,jj) * rl_sf ! Cosmetic psi (ji,jj,1) = rc0**rpp * en(ji,jj,1)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1) @@ -621,7 +624,7 @@ CONTAINS ! CASE ( 1 ) ! Neumann boundary condition on d(psi)/dz ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) ! Surface value: Dirichlet zdep (ji,jj) = zhsro(ji,jj) * rl_sf psi (ji,jj,1) = rc0**rpp * en(ji,jj,1)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1) @@ -657,7 +660,7 @@ CONTAINS CASE ( 0 ) ! Dirichlet ! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = vkarmn * r_z0_bot ! ! Balance between the production and the dissipation terms - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 zdep(ji,jj) = vkarmn * r_z0_bot @@ -675,7 +678,7 @@ CONTAINS END_2D ! IF( ln_isfcav) THEN ! top boundary (ocean cavity) - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) IF ( mikt(ji,jj) > 1 ) THEN itop = mikt(ji,jj) ! k top w-point itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one @@ -698,7 +701,7 @@ CONTAINS ! CASE ( 1 ) ! Neumman boundary condition ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 ! @@ -722,7 +725,7 @@ CONTAINS END_2D ! IF( ln_isfcav) THEN ! top boundary (ocean cavity) - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) IF ( mikt(ji,jj) > 1 ) THEN itop = mikt(ji,jj) ! k top w-point itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one @@ -755,13 +758,13 @@ CONTAINS ! Matrix inversion ! ---------------- ! - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) END_3D - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) END_3D - DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) END_3D @@ -771,17 +774,17 @@ CONTAINS SELECT CASE ( nn_clos ) ! CASE( 0 ) ! k-kl (Mellor-Yamada) - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin) END_3D ! CASE( 1 ) ! k-eps - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) eps(ji,jj,jk) = psi(ji,jj,jk) END_3D ! CASE( 2 ) ! k-w - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk) END_3D ! @@ -789,7 +792,7 @@ CONTAINS zcoef = rc0**( 3._wp + rpp/rnn ) zex1 = ( 1.5_wp + rmm/rnn ) zex2 = -1._wp / rnn - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2 END_3D ! @@ -797,13 +800,13 @@ CONTAINS ! Limit dissipation rate under stable stratification ! -------------------------------------------------- - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) ! Note that this set boundary conditions on hmxl_n at the same time + DO_3D_OVR( 0, 0, 0, 0, 1, jpkm1 ) ! Note that this set boundary conditions on hmxl_n at the same time ! limitation eps (ji,jj,jk) = MAX( eps(ji,jj,jk), rn_epsmin ) hmxl_n(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk) END_3D IF( ln_length_lim ) THEN ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated) - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpkm1 ) zrn2 = MAX( rn2(ji,jj,jk), rsmall ) hmxl_n(ji,jj,jk) = MIN( rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), hmxl_n(ji,jj,jk) ) END_3D @@ -816,7 +819,7 @@ CONTAINS SELECT CASE ( nn_stab_func ) ! CASE ( 0 , 1 ) ! Galperin or Kantha-Clayson stability functions - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! zcof = l²/q² zcof = hmxl_b(ji,jj,jk) * hmxl_b(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) ) ! Gh = -N²l²/q² @@ -833,7 +836,7 @@ CONTAINS END_3D ! CASE ( 2, 3 ) ! Canuto stability functions - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! zcof = l²/q² zcof = hmxl_b(ji,jj,jk)*hmxl_b(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) ) ! Gh = -N²l²/q² @@ -861,17 +864,17 @@ CONTAINS ! Boundary conditions on stability functions for momentum (Neumann): ! Lines below are useless if GOTM style Dirichlet conditions are used - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zstm(ji,jj,1) = zstm(ji,jj,2) zstm(ji,jj,jpk) = 0. ! default value, in case jpk > mbkt(ji,jj)+1 ! ! Not needed but avoid a bug when looking for undefined values (-fpe0) END_2D - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! update bottom with good values + DO_2D( 0, 0, 0, 0 ) ! update bottom with good values zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) END_2D - zstt(:,:, 1) = wmask(A2D(nn_hls), 1) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) - zstt(:,:,jpk) = wmask(A2D(nn_hls),jpk) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) + zstt(:,:, 1) = wmask(A2D(0), 1) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) + zstt(:,:,jpk) = wmask(A2D(0),jpk) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) !!gm should be done for ISF (top boundary cond.) !!gm so, totally new staff needed!!gm @@ -881,14 +884,14 @@ CONTAINS ! -> yes BUT p_avm(:,:1) and p_avm(:,:jpk) are used when we compute zd_lw(:,:2) and zd_up(:,:jpkm1). These values are ! later overwritten by surface/bottom boundaries conditions, so we don't really care of p_avm(:,:1) and p_avm(:,:jpk) ! for zd_lw and zd_up but they have to be defined to avoid a bug when looking for undefined values (-fpe0) - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpk ) zsqen = SQRT( 2._wp * en(ji,jj,jk) ) * hmxl_n(ji,jj,jk) zavt = zsqen * zstt(ji,jj,jk) zavm = zsqen * zstm(ji,jj,jk) p_avt(ji,jj,jk) = MAX( zavt, avtb(jk) ) * wmask(ji,jj,jk) ! apply mask for zdfmxl routine p_avm(ji,jj,jk) = MAX( zavm, avmb(jk) ) ! Note that avm is not masked at the surface and the bottom END_3D - p_avt(A2D(nn_hls),1) = 0._wp + p_avt(:,:,1) = 0._wp ! IF(sn_cfctl%l_prtctl) THEN CALL prt_ctl( tab3d_1=en , clinfo1=' gls - e: ', tab3d_2=p_avt, clinfo2=' t: ' ) @@ -1212,7 +1215,7 @@ CONTAINS ! ! !* Wall proximity function !!gm tmask or wmask ???? - zwall(:,:,:) = 1._wp * tmask(:,:,:) + zwall(:,:,:) = 1._wp * tmask(A2D(0),:) ! !* read or initialize all required files CALL gls_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, hmxl_n) diff --git a/src/OCE/ZDF/zdfiwm.F90 b/src/OCE/ZDF/zdfiwm.F90 index d0a9540eaa619d70c6eff3ba70b4c417f26f84d1..e28833945e7fb607c0ee805650e6386a1a5fc99e 100644 --- a/src/OCE/ZDF/zdfiwm.F90 +++ b/src/OCE/ZDF/zdfiwm.F90 @@ -65,8 +65,8 @@ CONTAINS !!---------------------------------------------------------------------- !! *** FUNCTION zdf_iwm_alloc *** !!---------------------------------------------------------------------- - ALLOCATE( ebot_iwm(jpi,jpj), ecri_iwm(jpi,jpj), ensq_iwm(jpi,jpj) , & - & esho_iwm(jpi,jpj), hbot_iwm(jpi,jpj), hcri_iwm(jpi,jpj) , STAT=zdf_iwm_alloc ) + ALLOCATE( ebot_iwm(A2D(0)), ecri_iwm(A2D(0)), ensq_iwm(A2D(0)) , & + & esho_iwm(A2D(0)), hbot_iwm(A2D(0)), hcri_iwm(A2D(0)) , STAT=zdf_iwm_alloc ) ! CALL mpp_sum ( 'zdfiwm', zdf_iwm_alloc ) IF( zdf_iwm_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_iwm_alloc: failed to allocate arrays' ) @@ -127,25 +127,25 @@ CONTAINS !! References : de Lavergne et al. JAMES 2020, https://doi.org/10.1029/2020MS002065 !! de Lavergne et al. JPO 2016, https://doi.org/10.1175/JPO-D-14-0259.1 !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! ocean time step - INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) - REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(A2D(0),jpk) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) ! INTEGER :: ji, jj, jk ! dummy loop indices REAL(wp), SAVE :: zztmp ! - REAL(wp), DIMENSION(A2D(nn_hls)) :: zfact ! Used for vertical structure - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zReb ! Turbulence intensity parameter - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zemx_iwm ! local energy density available for mixing (W/kg) - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T) - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zav_wave ! Internal wave-induced diffusivity + REAL(wp), DIMENSION(A2D(0)) :: zfact ! Used for vertical structure + REAL(wp), DIMENSION(A2D(0),jpk) :: zReb ! Turbulence intensity parameter + REAL(wp), DIMENSION(A2D(0),jpk) :: zemx_iwm ! local energy density available for mixing (W/kg) + REAL(wp), DIMENSION(A2D(0),jpk) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T) + REAL(wp), DIMENSION(A2D(0),jpk) :: zav_wave ! Internal wave-induced diffusivity REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d ! 3D workspace used for iom_put REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D - - - - !!---------------------------------------------------------------------- ! ! !* Initialize appropriately certain variables - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + DO_3D( 0, 0, 0, 0, 1, jpk ) zav_ratio(ji,jj,jk) = 1._wp * wmask(ji,jj,jk) ! important to set it to 1 here END_3D IF( iom_use("emix_iwm") ) zemx_iwm (:,:,:) = 0._wp @@ -157,13 +157,13 @@ CONTAINS ! ! !* 'cri' component: distribute energy over the time-varying ! !* ocean depth using an exponential decay from the seafloor. - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! part independent of the level + DO_2D( 0, 0, 0, 0 ) ! part independent of the level IF( ht(ji,jj) /= 0._wp ) THEN ; zfact(ji,jj) = ecri_iwm(ji,jj) * r1_rho0 / ( 1._wp - EXP( -ht(ji,jj) * hcri_iwm(ji,jj) ) ) ELSE ; zfact(ji,jj) = 0._wp ENDIF END_2D - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part zemx_iwm(ji,jj,jk) = zfact(ji,jj) * ( EXP( ( gdept(ji,jj,jk ,Kmm) - ht(ji,jj) ) * hcri_iwm(ji,jj) ) & & - EXP( ( gdept(ji,jj,jk-1,Kmm) - ht(ji,jj) ) * hcri_iwm(ji,jj) ) & & ) * wmask(ji,jj,jk) / e3w(ji,jj,jk,Kmm) @@ -171,13 +171,13 @@ CONTAINS !* 'bot' component: distribute energy over the time-varying !* ocean depth using an algebraic decay above the seafloor. - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! part independent of the level + DO_2D( 0, 0, 0, 0 ) ! part independent of the level IF( ht(ji,jj) /= 0._wp ) THEN ; zfact(ji,jj) = ebot_iwm(ji,jj) * ( 1._wp + hbot_iwm(ji,jj) / ht(ji,jj) ) * r1_rho0 ELSE ; zfact(ji,jj) = 0._wp ENDIF END_2D - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + & & zfact(ji,jj) * ( 1._wp / ( 1._wp + ( ht(ji,jj) - gdept(ji,jj,jk ,Kmm) ) / hbot_iwm(ji,jj) ) & & - 1._wp / ( 1._wp + ( ht(ji,jj) - gdept(ji,jj,jk-1,Kmm) ) / hbot_iwm(ji,jj) ) & @@ -186,50 +186,50 @@ CONTAINS !* 'nsq' component: distribute energy over the time-varying !* ocean depth as proportional to rn2 - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zfact(ji,jj) = 0._wp END_2D - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! part independent of the level + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! part independent of the level zfact(ji,jj) = zfact(ji,jj) + e3w(ji,jj,jk,Kmm) * MAX( 0._wp, rn2(ji,jj,jk) ) END_3D ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = ensq_iwm(ji,jj) * r1_rho0 / zfact(ji,jj) END_2D ! - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zfact(ji,jj) * MAX( 0._wp, rn2(ji,jj,jk) ) END_3D !* 'sho' component: distribute energy over the time-varying !* ocean depth as proportional to sqrt(rn2) - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zfact(ji,jj) = 0._wp END_2D - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! part independent of the level + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! part independent of the level zfact(ji,jj) = zfact(ji,jj) + e3w(ji,jj,jk,Kmm) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) ) END_3D ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = esho_iwm(ji,jj) * r1_rho0 / zfact(ji,jj) END_2D ! - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zfact(ji,jj) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) ) END_3D ! Calculate turbulence intensity parameter Reb - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) zReb(ji,jj,jk) = zemx_iwm(ji,jj,jk) / MAX( 1.e-20_wp, rnu * rn2(ji,jj,jk) ) END_3D ! ! Define internal wave-induced diffusivity - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) zav_wave(ji,jj,jk) = zReb(ji,jj,jk) * r1_6 * rnu ! This corresponds to a constant mixing efficiency of 1/6 END_3D ! IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224) regimes + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224) regimes IF( zReb(ji,jj,jk) > 480.00_wp ) THEN zav_wave(ji,jj,jk) = 3.6515_wp * rnu * SQRT( zReb(ji,jj,jk) ) ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN @@ -238,7 +238,7 @@ CONTAINS END_3D ENDIF ! - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Bound diffusivity by molecular value and 100 cm2/s + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Bound diffusivity by molecular value and 100 cm2/s zav_wave(ji,jj,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(ji,jj,jk) ), 1.e-2_wp ) * wmask(ji,jj,jk) END_3D ! @@ -247,7 +247,7 @@ CONTAINS ! ! ----------------------- ! ! IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Calculate S/T diffusivity ratio as a function of Reb (else it is set to 1) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Calculate S/T diffusivity ratio as a function of Reb (else it is set to 1) zav_ratio(ji,jj,jk) = ( 0.505_wp + & & 0.495_wp * TANH( 0.92_wp * ( LOG10( MAX( 1.e-20, zReb(ji,jj,jk) * 5._wp * r1_6 ) ) - 0.60_wp ) ) & & ) * wmask(ji,jj,jk) @@ -255,7 +255,7 @@ CONTAINS ENDIF CALL iom_put( "av_ratio", zav_ratio ) ! - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* update momentum & tracer diffusivity with wave-driven mixing + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) !* update momentum & tracer diffusivity with wave-driven mixing p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(ji,jj,jk) * zav_ratio(ji,jj,jk) p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zav_wave(ji,jj,jk) p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zav_wave(ji,jj,jk) @@ -265,7 +265,7 @@ CONTAINS !* output useful diagnostics: Kz*N^2 , ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm) IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN - ALLOCATE( z2d(A2D(nn_hls)) , z3d(A2D(nn_hls),jpk) ) + ALLOCATE( z2d(A2D(0)) , z3d(A2D(0),jpk) ) z2d(:,:) = 0._wp ; z3d(:,:,:) = 0._wp ! Initialisation for iom_put DO_3D( 0, 0, 0, 0, 2, jpkm1 ) z3d(ji,jj,jk) = MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) @@ -282,7 +282,7 @@ CONTAINS IF( .NOT. l_istiled .OR. ntile == 1 ) zztmp = 0._wp ! Do only on the first tile DO_3D( 0, 0, 0, 0, 2, jpkm1 ) zztmp = zztmp + e3w(ji,jj,jk,Kmm) * e1e2t(ji,jj) & - & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) + & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * smask0_i(ji,jj) END_3D IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile @@ -347,8 +347,8 @@ CONTAINS TYPE(FLD_N) :: sn_dsb, sn_dsc ! information about Decay Scale field to be read TYPE(FLD ), DIMENSION(jpiwm) :: sf_iwm ! structure of input fields (file informations, fields read) ! - REAL(wp), DIMENSION(jpi,jpj,4) :: ztmp - REAL(wp), DIMENSION(4) :: zdia + REAL(wp), DIMENSION(A2D(0),4) :: ztmp + REAL(wp), DIMENSION(4) :: zdia ! NAMELIST/namzdf_iwm/ ln_mevar, ln_tsdiff, & & cn_dir, sn_mpb, sn_mpc, sn_mpn, sn_mps, sn_dsb, sn_dsc @@ -390,8 +390,8 @@ CONTAINS slf_iwm(jp_dsb) = sn_dsb ; slf_iwm(jp_dsc) = sn_dsc ! DO ifpr= 1, jpiwm - ALLOCATE( sf_iwm(ifpr)%fnow(jpi,jpj,1) ) - IF( slf_iwm(ifpr)%ln_tint ) ALLOCATE( sf_iwm(ifpr)%fdta(jpi,jpj,1,2) ) + ALLOCATE( sf_iwm(ifpr)%fnow(A2D(0),1) ) + IF( slf_iwm(ifpr)%ln_tint ) ALLOCATE( sf_iwm(ifpr)%fdta(A2D(0),1,2) ) END DO ! fill sf_iwm with sf_iwm and control print @@ -408,10 +408,10 @@ CONTAINS ! ! read necessary fields CALL fld_read( nit000, 1, sf_iwm ) - ebot_iwm(:,:) = sf_iwm(1)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation above abyssal hills [W/m2] - ecri_iwm(:,:) = sf_iwm(2)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation at topographic slopes [W/m2] - ensq_iwm(:,:) = sf_iwm(3)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation scaling with N^2 [W/m2] - esho_iwm(:,:) = sf_iwm(4)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation due to shoaling [W/m2] + ebot_iwm(:,:) = sf_iwm(1)%fnow(:,:,1) * smask0(:,:) ! energy flux for dissipation above abyssal hills [W/m2] + ecri_iwm(:,:) = sf_iwm(2)%fnow(:,:,1) * smask0(:,:) ! energy flux for dissipation at topographic slopes [W/m2] + ensq_iwm(:,:) = sf_iwm(3)%fnow(:,:,1) * smask0(:,:) ! energy flux for dissipation scaling with N^2 [W/m2] + esho_iwm(:,:) = sf_iwm(4)%fnow(:,:,1) * smask0(:,:) ! energy flux for dissipation due to shoaling [W/m2] hbot_iwm(:,:) = sf_iwm(5)%fnow(:,:,1) ! spatially variable decay scale for abyssal hill dissipation [m] hcri_iwm(:,:) = sf_iwm(6)%fnow(:,:,1) ! spatially variable decay scale for topographic-slope [m] diff --git a/src/OCE/ZDF/zdfmfc.F90 b/src/OCE/ZDF/zdfmfc.F90 index f984b2bfa425f1ceb62b6c249dff7a5a3fca0a98..d83c10182986fd536c22af89210609dd1296a418 100644 --- a/src/OCE/ZDF/zdfmfc.F90 +++ b/src/OCE/ZDF/zdfmfc.F90 @@ -69,8 +69,8 @@ CONTAINS !!---------------------------------------------------------------------- !! *** FUNCTION zdf_edmf_alloc *** !!---------------------------------------------------------------------- - ALLOCATE( edmfa(jpi,jpj,jpk) , edmfb(jpi,jpj,jpk) , edmfc(jpi,jpj,jpk) & - & , edmftra(jpi,jpj,jpk,2), edmfm(jpi,jpj,jpk) , STAT= zdf_mfc_alloc ) + ALLOCATE( edmfa(A2D(0),jpk) , edmfb(A2D(0),jpk) , edmfc(A2D(0),jpk), & + & edmftra(A2D(0),jpk,2), edmfm(A2D(0),jpk) , STAT= zdf_mfc_alloc ) ! IF( lk_mpp ) CALL mpp_sum ( 'zdfmfc', zdf_mfc_alloc ) IF( zdf_mfc_alloc /= 0 ) CALL ctl_warn('zdf_mfc_alloc: failed to allocate arrays') @@ -97,24 +97,25 @@ CONTAINS REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: ztsp ! T/S of the plume REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: ztse ! T/S at W point - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zrwp ! - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zrwp2 ! - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zapp ! - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zedmf ! - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zepsT, zepsW ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zrautb, zraupl + REAL(wp), DIMENSION(A2D(0),jpk) :: zrwp ! + REAL(wp), DIMENSION(A2D(0),jpk) :: zrwp2 ! + REAL(wp), DIMENSION(A2D(0),jpk) :: zapp ! + REAL(wp), DIMENSION(A2D(0),jpk) :: zedmf ! + REAL(wp), DIMENSION(A2D(0),jpk) :: zepsT, zepsW ! ! - REAL(wp), DIMENSION(A2D(nn_hls)) :: zustar, zustar2 ! - REAL(wp), DIMENSION(A2D(nn_hls)) :: zuws, zvws, zsws, zfnet ! - REAL(wp), DIMENSION(A2D(nn_hls)) :: zfbuo, zrautbm1, zrautb, zraupl - REAL(wp), DIMENSION(A2D(nn_hls)) :: zwpsurf ! - REAL(wp), DIMENSION(A2D(nn_hls)) :: zop0 , zsp0 ! - REAL(wp), DIMENSION(A2D(nn_hls)) :: zrwp_0, zrwp2_0 ! - REAL(wp), DIMENSION(A2D(nn_hls)) :: zapp0 ! - REAL(wp), DIMENSION(A2D(nn_hls)) :: zphp, zph, zphpm1, zphm1, zNHydro - REAL(wp), DIMENSION(A2D(nn_hls)) :: zhcmo ! + REAL(wp), DIMENSION(A2D(0)) :: zustar, zustar2 ! + REAL(wp), DIMENSION(A2D(0)) :: zuws, zvws, zsws, zfnet ! + REAL(wp), DIMENSION(A2D(0)) :: zfbuo, zrautbm1 + REAL(wp), DIMENSION(A2D(0)) :: zwpsurf ! + REAL(wp), DIMENSION(A2D(0)) :: zop0 , zsp0 ! + REAL(wp), DIMENSION(A2D(0)) :: zrwp_0, zrwp2_0 ! + REAL(wp), DIMENSION(A2D(0)) :: zapp0 ! + REAL(wp), DIMENSION(A2D(0)) :: zphp, zph, zphpm1, zphm1, zNHydro + REAL(wp), DIMENSION(A2D(0)) :: zhcmo ! ! - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zn2 ! N^2 - REAL(wp), DIMENSION(A2D(nn_hls),2 ) :: zab, zabm1, zabp ! alpha and beta + REAL(wp), DIMENSION(A2D(0),jpk) :: zn2 ! N^2 + REAL(wp), DIMENSION(A2D(0),2 ) :: zab, zabm1, zabp ! alpha and beta REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value @@ -135,7 +136,7 @@ CONTAINS zcb = 1._wp zcd = 1._wp - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) !------------------------------------------------------------------ ! Surface boundary condition !------------------------------------------------------------------ @@ -160,8 +161,11 @@ CONTAINS !------------------------------------------- zrwp (ji,jj,:) = 0._wp ; zrwp2(ji,jj,:) = 0._wp ; zedmf(ji,jj,:) = 0._wp zph (ji,jj) = 0._wp ; zphm1(ji,jj) = 0._wp ; zphpm1(ji,jj) = 0._wp - ztsp(ji,jj,:,:)= 0._wp + END_2D + !clem: we should be able to do all calculations in the interior if eos is changed to allow A2D(0) arrays + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ztsp(ji,jj,:,:) = 0._wp ; ztse(ji,jj,:,:) = 0._wp ! Tracers inside plume (ztsp) and environment (ztse) ztsp(ji,jj,1,jp_tem) = pts(ji,jj,1,jp_tem,Kmm) * tmask(ji,jj,1) ztsp(ji,jj,1,jp_sal) = pts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1) @@ -175,12 +179,12 @@ CONTAINS !------------------------------------------- ! Boundary Condition of Mass Flux (plume velo.; convective area, entrain/detrain) !------------------------------------------- - zhcmo(:,:) = e3t(A1Di(nn_hls),A1Dj(nn_hls),1,Kmm) + zhcmo(:,:) = e3t(A1Di(0),A1Dj(0),1,Kmm) zfbuo(:,:) = 0._wp - WHERE ( ABS(zrautb(:,:)) > 1.e-20 ) zfbuo(:,:) = & + WHERE ( ABS(zrautb(A2D(0))) > 1.e-20 ) zfbuo(:,:) = & & grav * ( 2.e-4_wp *zfnet(:,:) & - & - 7.6E-4_wp*pts(A2D(nn_hls),1,jp_sal,Kmm) & - & * zsws(:,:)/zrautb(:,:)) * zhcmo(:,:) + & - 7.6E-4_wp*pts(A2D(0),1,jp_sal,Kmm) & + & * zsws(:,:)/zrautb(A2D(0))) * zhcmo(:,:) zedmf(:,:,1) = -0.065_wp*(ABS(zfbuo(:,:)))**(1._wp/3._wp)*SIGN(1.,zfbuo(:,:)) zedmf(:,:,1) = MAX(0., zedmf(:,:,1)) @@ -210,7 +214,7 @@ CONTAINS DO jk= 2, jpk ! Compute the buoyancy acceleration on T-points at jk-1 - zrautbm1(:,:) = zrautb(:,:) + zrautbm1(:,:) = zrautb(A2D(0)) CALL eos( pts (:,:,jk ,:,Kmm) , zrautb(:,:) ) CALL eos( ztsp(:,:,jk-1,: ) , zraupl(:,:) ) @@ -221,7 +225,7 @@ CONTAINS zph(ji,jj) = MAX( zph(ji,jj), zepsilon) END_2D - WHERE(zrautbm1 .NE. 0.) zfbuo(:,:) = grav * (zraupl(:,:) - zrautbm1(:,:)) / zrautbm1(:,:) + WHERE(zrautbm1 .NE. 0.) zfbuo(:,:) = grav * (zraupl(A2D(0)) - zrautbm1(:,:)) / zrautbm1(:,:) DO_2D( 0, 0, 0, 0 ) @@ -395,9 +399,9 @@ CONTAINS SUBROUTINE diag_mfc( zdiagi, zdiagd, zdiags, p2dt, Kaa ) - REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: zdiagi, zdiagd, zdiags ! inout: tridaig. terms - REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step - INTEGER , INTENT(in ) :: Kaa ! ocean time level indices + REAL(wp), DIMENSION(A2D(0),jpk), INTENT(inout) :: zdiagi, zdiagd, zdiags ! inout: tridaig. terms + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + INTEGER , INTENT(in ) :: Kaa ! ocean time level indices INTEGER :: ji, jj, jk ! dummy loop arguments diff --git a/src/OCE/ZDF/zdfmxl.F90 b/src/OCE/ZDF/zdfmxl.F90 index c387bdb14eb18cced95ea452b9f8f7c4906ce06a..e298785aaa146a0ee76d6d8c32b3e997ef2eeb72 100644 --- a/src/OCE/ZDF/zdfmxl.F90 +++ b/src/OCE/ZDF/zdfmxl.F90 @@ -51,7 +51,7 @@ CONTAINS !!---------------------------------------------------------------------- zdf_mxl_alloc = 0 ! set to zero if no array to be allocated IF( .NOT. ALLOCATED( nmln ) ) THEN - ALLOCATE( nmln(jpi,jpj), hmld(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), STAT= zdf_mxl_alloc ) + ALLOCATE( hmld(A2D(0)), nmln(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), STAT= zdf_mxl_alloc ) ! CALL mpp_sum ( 'zdfmxl', zdf_mxl_alloc ) IF( zdf_mxl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl_alloc: failed to allocate arrays.' ) @@ -109,8 +109,8 @@ CONTAINS ! IF( .NOT.l_offline .AND. iom_use("mldr10_1") ) THEN IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile - IF( ln_isfcav ) THEN ; CALL iom_put( "mldr10_1", hmlp - risfdep) ! mixed layer thickness - ELSE ; CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth + IF( ln_isfcav ) THEN ; CALL iom_put( "mldr10_1", hmlp(A2D(0)) - risfdep(A2D(0))) ! mixed layer thickness + ELSE ; CALL iom_put( "mldr10_1", hmlp(A2D(0)) ) ! mixed layer depth END IF ENDIF ENDIF @@ -138,24 +138,24 @@ CONTAINS ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: iik ! local integer - INTEGER, DIMENSION(A2D(nn_hls)) :: imld ! 2D workspace + INTEGER, DIMENSION(A2D(0)) :: imld ! 2D workspace !!---------------------------------------------------------------------- ! ! w-level of the turbocline and mixing layer (iom_use) - imld(:,:) = mbkt(A2D(nn_hls)) + 1 ! Initialization to the number of w ocean point - DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 + imld(:,:) = mbkt(A2D(0)) + 1 ! Initialization to the number of w ocean point + DO_3DS( 0, 0, 0, 0, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) ) imld(ji,jj) = jk ! Turbocline END_3D ! depth of the mixing layer - DO_2D_OVR( 1, 1, 1, 1 ) + DO_2D_OVR( 0, 0, 0, 0 ) iik = imld(ji,jj) hmld (ji,jj) = gdepw(ji,jj,iik ,Kmm) * ssmask(ji,jj) ! Turbocline depth END_2D ! IF( .NOT.l_offline .AND. iom_use("mldkz5") ) THEN IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile - IF( ln_isfcav ) THEN ; CALL iom_put( "mldkz5" , hmld - risfdep ) ! turbocline thickness - ELSE ; CALL iom_put( "mldkz5" , hmld ) ! turbocline depth + IF( ln_isfcav ) THEN ; CALL iom_put( "mldkz5" , hmld - risfdep(A2D(0)) ) ! turbocline thickness + ELSE ; CALL iom_put( "mldkz5" , hmld ) ! turbocline depth END IF ENDIF ENDIF diff --git a/src/OCE/ZDF/zdfphy.F90 b/src/OCE/ZDF/zdfphy.F90 index 5fbf2322015ec8b3097169ea4ac576cab62a9986..746614a3b7db9cdfd2c440007d5f0cc7cfafdf91 100644 --- a/src/OCE/ZDF/zdfphy.F90 +++ b/src/OCE/ZDF/zdfphy.F90 @@ -79,7 +79,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: Kmm ! time level index (middle) ! - INTEGER :: jk ! dummy loop indices + INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ioptio, ios ! local integers !! NAMELIST/namzdf/ ln_zdfcst, ln_zdfric, ln_zdftke, ln_zdfgls, & ! type of closure scheme @@ -164,13 +164,13 @@ CONTAINS ! ! -15S -5S : linear decrease from avt0 to avt0/10. ! ! -5S +5N : cst value avt0/10. ! ! 5N 15N : linear increase from avt0/10, to avt0 - WHERE(-15. <= gphit .AND. gphit < -5 ) avtb_2d = (1. - 0.09 * (gphit + 15.)) - WHERE( -5. <= gphit .AND. gphit < 5 ) avtb_2d = 0.1 - WHERE( 5. <= gphit .AND. gphit < 15 ) avtb_2d = (0.1 + 0.09 * (gphit - 5.)) + WHERE(-15. <= gphit(A2D(0)) .AND. gphit(A2D(0)) < -5 ) avtb_2d = (1. - 0.09 * (gphit(A2D(0)) + 15.)) + WHERE( -5. <= gphit(A2D(0)) .AND. gphit(A2D(0)) < 5 ) avtb_2d = 0.1 + WHERE( 5. <= gphit(A2D(0)) .AND. gphit(A2D(0)) < 15 ) avtb_2d = (0.1 + 0.09 * (gphit(A2D(0)) - 5.)) ENDIF ! DO jk = 1, jpk ! set turbulent closure Kz to the background value (avt_k, avm_k) - avt_k(:,:,jk) = avtb_2d(:,:) * avtb(jk) * wmask (:,:,jk) + avt_k(:,:,jk) = avtb_2d(:,:) * avtb(jk) * wmask (A2D(0),jk) avm_k(:,:,jk) = avmb(jk) * wmask (:,:,jk) END DO !!gm to be tested only the 1st & last levels @@ -178,7 +178,7 @@ CONTAINS ! avt (:,:,jpk) = 0._wp ; avs(:,:,jpk) = 0._wp ; avm (:,:,jpk) = 0._wp !!gm avt (:,:,:) = 0._wp ; avs(:,:,:) = 0._wp ; avm (:,:,:) = 0._wp - + ! !== Convection ==! ! IF( ln_zdfnpc .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfnpc and ln_zdfevd' ) @@ -255,7 +255,7 @@ CONTAINS INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! ocean time level indices ! INTEGER :: ji, jj, jk ! dummy loop indice - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zsh2 ! shear production + REAL(wp), DIMENSION(A2D(0),jpk) :: zsh2 ! shear production !! --------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('zdf_phy') @@ -308,6 +308,9 @@ CONTAINS CASE( np_TKE ) ; CALL zdf_tke( kt, Kbb, Kmm, zsh2, avm_k, avt_k ) ! TKE closure scheme for Kz CASE( np_GLS ) ; CALL zdf_gls( kt, Kbb, Kmm, zsh2, avm_k, avt_k ) ! GLS closure scheme for Kz CASE( np_OSM ) ; CALL zdf_osm( kt, Kbb, Kmm, Krhs, avm_k, avt_k ) ! OSMOSIS closure scheme for Kz + ! ! clem: osmosis currently cannot work because + ! it uses qns and qsr that are only defined in the interior (A2D(0)) + ! we should do calculations in the interior and put a lbc_lnk at the end ! CASE( np_CST ) ! Constant Kz (reset avt, avm to the background value) ! ! avt_k and avm_k set one for all at initialisation phase !!gm avt(2:jpim1,2:jpjm1,1:jpkm1) = rn_avt0 * wmask(2:jpim1,2:jpjm1,1:jpkm1) @@ -323,13 +326,13 @@ CONTAINS #endif ! ! !* start from turbulent closure values - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) avt(ji,jj,jk) = avt_k(ji,jj,jk) avm(ji,jj,jk) = avm_k(ji,jj,jk) END_3D ! IF( ln_rnf_mouth ) THEN !* increase diffusivity at rivers mouths - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, nkrnf ) + DO_3D_OVR( 0, 0, 0, 0, 2, nkrnf ) avt(ji,jj,jk) = avt(ji,jj,jk) + 2._wp * rn_avt_rnf * rnfmsk(ji,jj) * wmask(ji,jj,jk) END_3D ENDIF @@ -340,7 +343,7 @@ CONTAINS IF( ln_zdfddm ) THEN ! update avt and compute avs CALL zdf_ddm( kt, Kmm, avm, avt, avs ) ELSE ! same mixing on all tracers - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 1, jpkm1 ) avs(ji,jj,jk) = avt(ji,jj,jk) END_3D ENDIF @@ -350,14 +353,18 @@ CONTAINS IF( ln_zdfiwm ) CALL zdf_iwm( kt, Kmm, avm, avt, avs ) ! internal wave (de Lavergne et al 2017) ! !* Lateral boundary conditions (sign unchanged) - IF(nn_hls==1) THEN ! if nn_hls==2 lbc_lnk done in stp routines - IF( l_zdfsh2 ) THEN - CALL lbc_lnk( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp, & - & avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) - ELSE - CALL lbc_lnk( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) - ENDIF + !clem: this is probably not compatible with tiling + !clem: calculating avm, avt and avt in the interior only allows to have most of SBC arrays only defined in the interior + ! but then one needs a lbc_lnk. If this lbc is critical, then one should get back to calculations on (nn_hls-1) +!!$ IF(nn_hls==1) THEN ! if nn_hls==2 lbc_lnk done in stp routines + IF( l_zdfsh2 ) THEN + CALL lbc_lnk( 'zdfphy', avm, 'W', 1.0_wp, avm_k, 'W', 1.0_wp ) + ELSE + CALL lbc_lnk( 'zdfphy', avm, 'W', 1.0_wp ) + ENDIF ! +!!$ ENDIF + IF(nn_hls==1) THEN IF( l_zdfdrg ) THEN ! drag have been updated (non-linear cases) IF( ln_isfcav ) THEN ; CALL lbc_lnk( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp ) ! top & bot drag ELSE ; CALL lbc_lnk( 'zdfphy', rCdU_bot, 'T', 1.0_wp ) ! bottom drag only @@ -379,10 +386,10 @@ CONTAINS ! diagnostics of energy dissipation IF( iom_use('avt_k') .OR. iom_use('avm_k') .OR. iom_use('eshear_k') .OR. iom_use('estrat_k') ) THEN IF( l_zdfsh2 ) THEN - CALL iom_put( 'avt_k' , avt_k * wmask ) - CALL iom_put( 'avm_k' , avm_k * wmask ) - CALL iom_put( 'eshear_k', zsh2 * wmask ) - CALL iom_put( 'estrat_k', - avt_k * rn2 * wmask ) + CALL iom_put( 'avt_k' , avt_k * wmask(A2D(0),:) ) + CALL iom_put( 'avm_k' , avm_k * wmask(A2D(0),:) ) + CALL iom_put( 'eshear_k', zsh2 * wmask(A2D(0),:) ) + CALL iom_put( 'estrat_k', - avt_k * rn2 * wmask(A2D(0),:) ) ENDIF ENDIF ! diff --git a/src/OCE/ZDF/zdfric.F90 b/src/OCE/ZDF/zdfric.F90 index 655cf49cd9aa011a59cae2dba1d7a0e922caac5e..44a635a15f5520297e09cd7b2857ae34c1793d9d 100644 --- a/src/OCE/ZDF/zdfric.F90 +++ b/src/OCE/ZDF/zdfric.F90 @@ -145,18 +145,19 @@ CONTAINS !! References : Pacanowski & Philander 1981, JPO, 1441-1451. !! PFJ Lermusiaux 2001. !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! ocean time-step - INTEGER , INTENT(in ) :: Kmm ! ocean time level index - REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term - REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + INTEGER , INTENT(in ) :: kt ! ocean time-step + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(A2D(0),jpk), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(A2D(0),jpk), INTENT(inout) :: p_avt ! tracer Kz (w-points) !! INTEGER :: ji, jj, jk ! dummy loop indices REAL(wp) :: zcfRi, zav, zustar, zhek ! local scalars - REAL(wp), DIMENSION(A2D(nn_hls)) :: zh_ekm ! 2D workspace + REAL(wp), DIMENSION(A2D(0)) :: zh_ekm ! 2D workspace !!---------------------------------------------------------------------- ! ! !== avm and avt = F(Richardson number) ==! - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! coefficient = F(richardson number) (avm-weighted Ri) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) ! coefficient = F(richardson number) (avm-weighted Ri) zcfRi = 1._wp / ( 1._wp + rn_alp * MAX( 0._wp , avm(ji,jj,jk) * rn2(ji,jj,jk) / ( p_sh2(ji,jj,jk) + 1.e-20 ) ) ) zav = rn_avmri * zcfRi**nn_ric ! ! avm and avt coefficients @@ -169,12 +170,12 @@ CONTAINS ! IF( ln_mldw ) THEN !== set a minimum value in the Ekman layer ==! ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zustar = SQRT( taum(ji,jj) * r1_rho0 ) zhek = rn_ekmfc * zustar / ( ABS( ff_t(ji,jj) ) + rsmall ) ! Ekman depth zh_ekm(ji,jj) = MAX( rn_mldmin , MIN( zhek , rn_mldmax ) ) ! set allowed range END_2D - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* minimum mixing coeff. within the Ekman layer + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) !* minimum mixing coeff. within the Ekman layer IF( gdept(ji,jj,jk,Kmm) < zh_ekm(ji,jj) ) THEN p_avm(ji,jj,jk) = MAX( p_avm(ji,jj,jk), rn_wvmix ) * wmask(ji,jj,jk) p_avt(ji,jj,jk) = MAX( p_avt(ji,jj,jk), rn_wtmix ) * wmask(ji,jj,jk) diff --git a/src/OCE/ZDF/zdfsh2.F90 b/src/OCE/ZDF/zdfsh2.F90 index 1654a2e108794755cdf998476e0c3b505e01e364..8aa5a73402da70ef303cf23e959b8c22360dea7b 100644 --- a/src/OCE/ZDF/zdfsh2.F90 +++ b/src/OCE/ZDF/zdfsh2.F90 @@ -54,17 +54,17 @@ CONTAINS !! ***** !! References : Bruchard, OM 2002 !! --------------------------------------------------------------------- - INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points) - REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points) + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points) + REAL(wp), DIMENSION(A2D(0),jpk) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points) ! INTEGER :: ji, jj, jk ! dummy loop arguments - REAL(wp), DIMENSION(A2D(nn_hls)) :: zsh2u, zsh2v ! 2D workspace + REAL(wp), DIMENSION(A2D(1)) :: zsh2u, zsh2v ! 2D workspace !!-------------------------------------------------------------------- ! DO jk = 2, jpkm1 !* Shear production at uw- and vw-points (energy conserving form) IF ( cpl_sdrftx .AND. ln_stshear ) THEN ! Surface Stokes Drift available ===>>> shear + stokes drift contibution - DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + DO_2D( 1, 0, 1, 0 ) zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & & * ( uu (ji,jj,jk-1,Kmm) - uu (ji,jj,jk,Kmm) & & + usd(ji,jj,jk-1) - usd(ji,jj,jk) ) & @@ -77,7 +77,7 @@ CONTAINS &/ ( e3vw(ji,jj,jk,Kmm) * e3vw(ji,jj,jk,Kbb) ) * wvmask(ji,jj,jk) END_2D ELSE - DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) !* 2 x shear production at uw- and vw-points (energy conserving form) + DO_2D( 1, 0, 1, 0 ) !* 2 x shear production at uw- and vw-points (energy conserving form) zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & & * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) & & * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) & @@ -90,12 +90,12 @@ CONTAINS & * wvmask(ji,jj,jk) END_2D ENDIF - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked) + DO_2D( 0, 0, 0, 0 ) !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked) p_sh2(ji,jj,jk) = 0.25 * ( ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) ) & & + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) ) ) END_2D END DO - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! set p_sh2 to 0 at the surface and bottom for output purpose + DO_2D( 0, 0, 0, 0 ) ! set p_sh2 to 0 at the surface and bottom for output purpose p_sh2(ji,jj,1) = 0._wp p_sh2(ji,jj,jpk) = 0._wp END_2D diff --git a/src/OCE/ZDF/zdfswm.F90 b/src/OCE/ZDF/zdfswm.F90 index 7c6f94d880a51483d01c0a01febba8e4f59b60cb..9a3b20585c3bbd4096f7b4ac3418085c805a845e 100644 --- a/src/OCE/ZDF/zdfswm.F90 +++ b/src/OCE/ZDF/zdfswm.F90 @@ -53,17 +53,17 @@ CONTAINS !! !! reference : Qiao et al. GRL, 2004 !!--------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! ocean time step - INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) - REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(A2D(0),jpk) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) ! INTEGER :: ji, jj, jk ! dummy loop indices REAL(wp):: zcoef, zqb ! local scalar !!--------------------------------------------------------------------- ! zcoef = 1._wp * 0.353553_wp - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) zqb = zcoef * hsw(ji,jj) * tsd2d(ji,jj) * EXP( -3. * wnum(ji,jj) * gdepw(ji,jj,jk,Kmm) ) * wmask(ji,jj,jk) ! p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zqb diff --git a/src/OCE/ZDF/zdftke.F90 b/src/OCE/ZDF/zdftke.F90 index 4d3adbd3e83c02c0f3c65f59097220966c61052a..e2285b2c8e9fc39002523b6bec07966a4f7ceda3 100644 --- a/src/OCE/ZDF/zdftke.F90 +++ b/src/OCE/ZDF/zdftke.F90 @@ -114,7 +114,7 @@ CONTAINS !!---------------------------------------------------------------------- !! *** FUNCTION zdf_tke_alloc *** !!---------------------------------------------------------------------- - ALLOCATE( htau(jpi,jpj) , dissl(jpi,jpj,jpk) , apdlr(jpi,jpj,jpk) , STAT= zdf_tke_alloc ) + ALLOCATE( htau(A2D(0)) , dissl(A2D(0),jpk) , apdlr(A2D(0),jpk) , STAT= zdf_tke_alloc ) ! CALL mpp_sum ( 'zdftke', zdf_tke_alloc ) IF( zdf_tke_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tke_alloc: failed to allocate arrays' ) @@ -167,10 +167,11 @@ CONTAINS !! Axell, JGR, 2002 !! Bruchard OM 2002 !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! ocean time step - INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term - REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(A2D(0),jpk), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(A2D(0),jpk), INTENT(inout) :: p_avt ! tracer Kz (w-points) !!---------------------------------------------------------------------- ! CALL tke_tke( Kbb, Kmm, p_sh2, p_avm, p_avt ) ! now tke (en) @@ -200,9 +201,10 @@ CONTAINS !! --------------------------------------------------------------------- USE zdf_oce , ONLY : en ! ocean vertical physics !! - INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in ) :: p_sh2 ! shear production term - REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(A2D(0),jpk) , INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(A2D(0),jpk) , INTENT(in ) :: p_avt ! tracer Kz (w-points) ! INTEGER :: ji, jj, jk ! dummy loop arguments REAL(wp) :: zetop, zebot, zmsku, zmskv ! local scalars @@ -215,9 +217,9 @@ CONTAINS REAL(wp) :: zus , zwlc , zind ! - - REAL(wp) :: zzd_up, zzd_lw ! - - REAL(wp) :: ztaui, ztauj, z1_norm - INTEGER , DIMENSION(A2D(nn_hls)) :: imlc - REAL(wp), DIMENSION(A2D(nn_hls)) :: zice_fra, zhlc, zus3, zWlc2 - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpelc, zdiag, zd_up, zd_lw + INTEGER , DIMENSION(A2D(0)) :: imlc + REAL(wp), DIMENSION(A2D(0)) :: zice_fra, zhlc, zus3, zWlc2 + REAL(wp), DIMENSION(A2D(0),jpk) :: zpelc, zdiag, zd_up, zd_lw REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztmp ! for diags !!-------------------------------------------------------------------- ! @@ -232,16 +234,16 @@ CONTAINS ! ice fraction considered for attenuation of langmuir & wave breaking SELECT CASE ( nn_eice ) CASE( 0 ) ; zice_fra(:,:) = 0._wp - CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(A2D(nn_hls)) * 10._wp ) - CASE( 2 ) ; zice_fra(:,:) = fr_i(A2D(nn_hls)) - CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(A2D(nn_hls)) , 1._wp ) + CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(A2D(0)) * 10._wp ) + CASE( 2 ) ; zice_fra(:,:) = fr_i(A2D(0)) + CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(A2D(0)) , 1._wp ) END SELECT ! ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! ! Surface/top/bottom boundary condition on tke ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) zd_lw(ji,jj,1) = 1._wp @@ -258,7 +260,7 @@ CONTAINS ! IF( .NOT.ln_drg_OFF ) THEN !== friction used as top/bottom boundary condition on TKE ! - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! bottom friction + DO_2D_OVR( 0, 0, 0, 0 ) ! bottom friction zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! ! where 0.001875 = (rn_ebb0/rho0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) @@ -267,7 +269,7 @@ CONTAINS en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) END_2D IF( ln_isfcav ) THEN - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! top friction + DO_2D_OVR( 0, 0, 0, 0 ) ! top friction zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! ! where 0.001875 = (rn_ebb0/rho0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) @@ -294,14 +296,14 @@ CONTAINS ! ! 1/2 (W_lc)^2 = MAX( u* u_s + v* v_s , 0 ) only the positive part !!gm ! PS: currently we don't have neither the 2 stress components at t-point !nor the angle between u* and u_s !!gm ! so we will overestimate the LC velocity.... !!gm I will do the work if !LC have an effect ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) !!XC zWlc2(ji,jj) = 0.5_wp * SQRT( taum(ji,jj) * r1_rho0 * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) ) zWlc2(ji,jj) = 0.5_wp * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) END_2D ! ! Projection of Stokes drift in the wind stress direction ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) ztaui = utau(ji,jj) ztauj = vtau(ji,jj) z1_norm = 1._wp / MAX( SQRT(ztaui*ztaui+ztauj*ztauj), 1.e-12 ) * tmask(ji,jj,1) @@ -313,7 +315,7 @@ CONTAINS ! ! Wlc = 0.016 * [|tau|/(rho_air Cdrag) ]^1/2 and thus: ! ! 1/2 Wlc^2 = 0.5 * 0.016 * 0.016 |tau| /( rho_air Cdrag ) zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) ! to convert stress in 10m wind using a constant drag - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zWlc2(ji,jj) = zcof * taum(ji,jj) END_2D ! @@ -321,30 +323,30 @@ CONTAINS ! ! !* Depth of the LC circulation (Axell 2002, Eq.47) ! !- LHS of Eq.47 - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zpelc(ji,jj,1) = MAX( rn2b(ji,jj,1), 0._wp ) * gdepw(ji,jj,1,Kmm) * e3w(ji,jj,1,Kmm) END_2D - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpk ) + DO_3D( 0, 0, 0, 0, 2, jpk ) zpelc(ji,jj,jk) = zpelc(ji,jj,jk-1) + & & MAX( rn2b(ji,jj,jk), 0._wp ) * gdepw(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) END_3D ! ! !- compare LHS to RHS of Eq.47 - imlc(:,:) = mbkt(A2D(nn_hls)) + 1 ! Initialization to the number of w ocean point (=2 over land) - DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) + imlc(:,:) = mbkt(A2D(0)) + 1 ! Initialization to the number of w ocean point (=2 over land) + DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) IF( zpelc(ji,jj,jk) > zWlc2(ji,jj) ) imlc(ji,jj) = jk END_3D ! ! finite LC depth - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zhlc(ji,jj) = gdepw(ji,jj,imlc(ji,jj),Kmm) END_2D ! zcof = 0.016 / SQRT( zrhoa * zcdrag ) - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zus = SQRT( 2. * zWlc2(ji,jj) ) ! Stokes drift zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok END_2D - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* TKE Langmuir circulation source term added to en + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) !* TKE Langmuir circulation source term added to en IF ( zus3(ji,jj) /= 0._wp ) THEN IF ( gdepw(ji,jj,jk,Kmm) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN ! ! vertical velocity due to LC @@ -365,7 +367,7 @@ CONTAINS ! ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal ! IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri ) - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) ! ! local Richardson number IF (rn2b(ji,jj,jk) <= 0.0_wp) then zri = 0.0_wp @@ -377,7 +379,7 @@ CONTAINS END_3D ENDIF ! - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* Matrix and right hand side in en + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) !* Matrix and right hand side in en zcof = zfact1 * tmask(ji,jj,jk) ! ! A minimum of 2.e-5 m2/s is imposed on TKE vertical ! ! eddy coefficient (ensure numerical stability) @@ -406,14 +408,14 @@ CONTAINS SELECT CASE (nn_bc_surf) ! Boundary Condition using surface TKE flux from waves CASE ( 0 ) ! Dirichlet BC - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! en(1) = rn_ebb taum / rho0 (min value rn_emin0) + DO_2D_OVR( 0, 0, 0, 0 ) ! en(1) = rn_ebb taum / rho0 (min value rn_emin0) IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp en(ji,jj,1) = MAX( rn_emin0, .5 * ( 15.8 * phioc(ji,jj) / rho0 )**(2./3.) ) * tmask(ji,jj,1) zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) ! choose to keep coherence with former estimation of END_2D CASE ( 1 ) ! Neumann BC - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp en(ji,jj,2) = en(ji,jj,2) + ( rn_Dt * phioc(ji,jj) / rho0 ) /e3w(ji,jj,2,Kmm) en(ji,jj,1) = en(ji,jj,2) + (2 * e3t(ji,jj,1,Kmm) * phioc(ji,jj)/rho0) / ( p_avm(ji,jj,1) + p_avm(ji,jj,2) ) @@ -427,23 +429,23 @@ CONTAINS ENDIF ! ! !* Matrix inversion from level 2 (tke prescribed at level 1) - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) END_3D !XC : commented to allow for neumann boundary condition ! DO_2D( 0, 0, 0, 0 ) ! zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke ! END_2D - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) END_3D - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + DO_2D_OVR( 0, 0, 0, 0 ) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) END_2D - DO_3DS_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, 2, -1 ) + DO_3DS_OVR( 0, 0, 0, 0, jpk-2, 2, -1 ) en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) END_3D - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! set the minimum value of tke + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) ! set the minimum value of tke en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) END_3D ! @@ -451,11 +453,11 @@ CONTAINS ! ediss = Ce*sqrt(en)/L*en ! dissl = sqrt(en)/L IF( iom_use('ediss_k') ) THEN - ALLOCATE( ztmp(A2D(nn_hls),jpk) ) - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + ALLOCATE( ztmp(A2D(0),jpk) ) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ztmp(ji,jj,jk) = zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk) * wmask(ji,jj,jk) END_3D - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) ztmp(ji,jj,jpk) = 0._wp END_2D CALL iom_put( 'ediss_k', ztmp ) @@ -471,18 +473,18 @@ CONTAINS ! penetration is partly switched off below sea-ice if nn_eice/=0 ! IF( nn_etau == 1 ) THEN !* penetration below the mixed layer (rn_efr fraction) - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) END_3D ELSEIF( nn_etau == 2 ) THEN !* act only at the base of the mixed layer (jk=nmln) (rn_efr fraction) - DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D_OVR( 0, 0, 0, 0 ) jk = nmln(ji,jj) en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) END_2D ELSEIF( nn_etau == 3 ) THEN !* penetration belox the mixed layer (HF variability) - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) ztau = SQRT( utau(ji,jj)*utau(ji,jj) + vtau(ji,jj)*vtau(ji,jj) ) * tmask(ji,jj,1) ! module of the mean stress zdif = taum(ji,jj) - ztau ! mean of modulus - modulus of the mean zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... @@ -530,14 +532,15 @@ CONTAINS !!---------------------------------------------------------------------- USE zdf_oce , ONLY : en, avtb, avmb, avtb_2d ! ocean vertical physics !! - INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(A2D(0),jpk), INTENT( out) :: p_avt ! tracer Kz (w-points) ! INTEGER :: ji, jj, jk ! dummy loop indices REAL(wp) :: zrn2, zraug, zcoef, zav ! local scalars REAL(wp) :: zdku, zdkv, zsqen ! - - REAL(wp) :: zemxl, zemlm, zemlp, zmaxice ! - - - REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zmxlm, zmxld ! 3D workspace + REAL(wp), DIMENSION(A2D(0),jpk) :: zmxlm, zmxld ! 3D workspace !!-------------------------------------------------------------------- ! ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @@ -561,25 +564,25 @@ CONTAINS ! zraug = vkarmn * 2.e5_wp / ( rho0 * grav ) #if ! defined key_si3 && ! defined key_cice - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! No sea-ice + DO_2D( 0, 0, 0, 0 ) ! No sea-ice zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) END_2D #else SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice ! CASE( 0 ) ! No scaling under sea-ice - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) END_2D ! CASE( 1 ) ! scaling with constant sea-ice thickness - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & & fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) END_2D ! CASE( 2 ) ! scaling with mean sea-ice thickness - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) #if defined key_si3 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & & fr_i(ji,jj) * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) @@ -591,7 +594,7 @@ CONTAINS END_2D ! CASE( 3 ) ! scaling with max sea-ice thickness - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zmaxice = MAXVAL( h_i(ji,jj,:) ) zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) @@ -600,7 +603,7 @@ CONTAINS END SELECT #endif ! - DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO_2D( 0, 0, 0, 0 ) zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) END_2D ! @@ -609,7 +612,7 @@ CONTAINS ENDIF ENDIF ! - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) zrn2 = MAX( rn2(ji,jj,jk), rsmall ) zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) END_3D @@ -624,7 +627,7 @@ CONTAINS !!gm Not sure of that coding for ISF.... ! where wmask = 0 set zmxlm == e3w(:,:,:,Kmm) CASE ( 0 ) ! bounded by the distance to surface and bottom - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) zemxl = MIN( gdepw(ji,jj,jk,Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm), zmxlm(ji,jj,jk), & & gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) - gdepw(ji,jj,jk,Kmm) ) ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) @@ -635,33 +638,33 @@ CONTAINS END_3D ! CASE ( 1 ) ! bounded by the vertical scale factor - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) zemxl = MIN( e3w(ji,jj,jk,Kmm), zmxlm(ji,jj,jk) ) zmxlm(ji,jj,jk) = zemxl zmxld(ji,jj,jk) = zemxl END_3D ! CASE ( 2 ) ! |dk[xml]| bounded by e3t : - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! from the surface to the bottom : + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! from the surface to the bottom : zmxlm(ji,jj,jk) = & & MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) END_3D - DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! from the bottom to the surface : + DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! from the bottom to the surface : zemxl = MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) zmxlm(ji,jj,jk) = zemxl zmxld(ji,jj,jk) = zemxl END_3D ! CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t : - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! from the surface to the bottom : lup + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! from the surface to the bottom : lup zmxld(ji,jj,jk) = & & MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) END_3D - DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! from the bottom to the surface : ldown + DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! from the bottom to the surface : ldown zmxlm(ji,jj,jk) = & & MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) END_3D - DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) zemlm = MIN ( zmxld(ji,jj,jk), zmxlm(ji,jj,jk) ) zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) ) zmxlm(ji,jj,jk) = zemlm @@ -673,7 +676,7 @@ CONTAINS ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! ! Vertical eddy viscosity and diffusivity (avm and avt) ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* vertical eddy viscosity & diffivity at w-points + DO_3D_OVR( 0, 0, 0, 0, 1, jpkm1 ) !* vertical eddy viscosity & diffivity at w-points zsqen = SQRT( en(ji,jj,jk) ) zav = rn_ediff * zmxlm(ji,jj,jk) * zsqen p_avm(ji,jj,jk) = MAX( zav, avmb(jk) ) * wmask(ji,jj,jk) @@ -683,7 +686,7 @@ CONTAINS ! ! IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt - DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + DO_3D_OVR( 0, 0, 0, 0, 2, jpkm1 ) p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) END_3D ENDIF @@ -863,14 +866,14 @@ CONTAINS ELSE ! start TKE from rest IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) ' ==>>> previous run without TKE scheme, set en to background values' - en (:,:,:) = rn_emin * wmask(:,:,:) + en (:,:,:) = rn_emin * wmask(A2D(0),:) dissl(:,:,:) = 1.e-12_wp ! avt_k, avm_k already set to the background value in zdf_phy_init ENDIF ELSE !* Start from rest IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set en to the background value' - en (:,:,:) = rn_emin * wmask(:,:,:) + en (:,:,:) = rn_emin * wmask(A2D(0),:) dissl(:,:,:) = 1.e-12_wp ! avt_k, avm_k already set to the background value in zdf_phy_init ENDIF diff --git a/src/OCE/lib_fortran.F90 b/src/OCE/lib_fortran.F90 index 2a0e1eeda7dc2ce685e4c2309ebe4ee2d7fa28ff..a9857b8ae08f7247a98aa6c36787d428c728f55d 100644 --- a/src/OCE/lib_fortran.F90 +++ b/src/OCE/lib_fortran.F90 @@ -304,9 +304,9 @@ CONTAINS IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) iis = Nis0 ; iie = Nie0 ijs = Njs0 ; ije = Nje0 - ELSE ! I think we are never in this case... - iis = 1 ; iie = jpi - ijs = 1 ; ije = jpj + ELSE ! if ptab is not defined over the whole domain (-> avoid out of bounds) + iis = 1 ; iie = jpi-2*nn_hls + ijs = 1 ; ije = jpj-2*nn_hls ENDIF ! ALLOCATE( ctmp(ipk) ) @@ -349,9 +349,9 @@ CONTAINS IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) iis = Nis0 ; iie = Nie0 ijs = Njs0 ; ije = Nje0 - ELSE ! I think we are never in this case... - iis = 1 ; iie = jpi - ijs = 1 ; ije = jpj + ELSE ! if ptab is not defined over the whole domain (-> avoid out of bounds) + iis = 1 ; iie = jpi-2*nn_hls + ijs = 1 ; ije = jpj-2*nn_hls ENDIF ! ALLOCATE( ctmp(ipl) ) diff --git a/src/OCE/lib_fortran_generic.h90 b/src/OCE/lib_fortran_generic.h90 index d09c2cd02c0b8017ee22418376955dc8043e7265..e0702190b3fe70a1707e95eee7c4249926bb22e0 100644 --- a/src/OCE/lib_fortran_generic.h90 +++ b/src/OCE/lib_fortran_generic.h90 @@ -4,8 +4,6 @@ # define XD 1d # define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k) # define ARRAY_IN(i,j,k) ptab(i) -# define ARRAY2_IN(i,j,k) ptab2(i) -# define J_SIZE(ptab) 1 # define K_SIZE(ptab) 1 # define MASK_ARRAY(i,j) 1. # endif @@ -13,8 +11,6 @@ # define XD 2d # define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k) # define ARRAY_IN(i,j,k) ptab(i,j) -# define ARRAY2_IN(i,j,k) ptab2(i,j) -# define J_SIZE(ptab) SIZE(ptab,2) # define K_SIZE(ptab) 1 # define MASK_ARRAY(i,j) tmask_i(i,j) # endif @@ -22,8 +18,6 @@ # define XD 3d # define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k) # define ARRAY_IN(i,j,k) ptab(i,j,k) -# define ARRAY2_IN(i,j,k) ptab2(i,j,k) -# define J_SIZE(ptab) SIZE(ptab,2) # define K_SIZE(ptab) SIZE(ptab,3) # define MASK_ARRAY(i,j) tmask_i(i,j) # endif @@ -39,31 +33,31 @@ COMPLEX(dp):: ctmp REAL(wp) :: ztmp INTEGER :: ji, jj, jk ! dummy loop indices - INTEGER :: ipi,ipj, ipk ! dimensions - INTEGER :: iis, iie, ijs, ije ! loop start and end + INTEGER :: ipi, ipj, ipk ! dimensions + INTEGER :: iisht, ijsht !!----------------------------------------------------------------------- ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + ! +# if defined DIM_1d + DO ji = 1, SIZE(ptab,1) + CALL DDPDD( CMPLX( ptab(ji), 0.e0, dp ), ctmp ) + END DO +# else ipi = SIZE(ptab,1) ! 1st dimension - ipj = J_SIZE(ptab) ! 2nd dimension + ipj = SIZE(ptab,2) ! 2nd dimension ipk = K_SIZE(ptab) ! 3rd dimension ! - IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) - iis = Nis0 ; iie = Nie0 - ijs = Njs0 ; ije = Nje0 - ELSE - iis = 1 ; iie = ipi - ijs = 1 ; ije = ipj - ENDIF + iisht = ( jpi - ipi ) / 2 + ijsht = ( jpj - ipj ) / 2 ! should be the same as iisht... ! - ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated DO jk = 1, ipk - DO jj = ijs, ije - DO ji = iis, iie - ztmp = ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj) - CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) - END DO - END DO + DO_2D( 0, 0, 0, 0 ) + ztmp = ARRAY_IN(ji-iisht,jj-ijsht,jk) * MASK_ARRAY(ji,jj) ! warning tmask_iis defined over the full MPI domain + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END_2D END DO +# endif CALL mpp_sum( cdname, ctmp ) ! sum over the global domain glob_sum_/**/XD = REAL(ctmp,wp) @@ -71,10 +65,7 @@ #undef XD #undef ARRAY_TYPE -#undef ARRAY2_TYPE #undef ARRAY_IN -#undef ARRAY2_IN -#undef J_SIZE #undef K_SIZE #undef MASK_ARRAY ! @@ -85,14 +76,12 @@ # define XD 2d # define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k) # define ARRAY_IN(i,j,k) ptab(i,j) -# define ARRAY2_IN(i,j,k) ptab2(i,j) # define K_SIZE(ptab) 1 # endif # if defined DIM_3d # define XD 3d # define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k) # define ARRAY_IN(i,j,k) ptab(i,j,k) -# define ARRAY2_IN(i,j,k) ptab2(i,j,k) # define K_SIZE(ptab) SIZE(ptab,3) # endif # if defined OPERATION_GLOBMIN @@ -113,27 +102,31 @@ COMPLEX(dp):: ctmp REAL(wp) :: ztmp INTEGER :: jk ! dummy loop indices - INTEGER :: ipk ! dimensions + INTEGER :: ipi, ipj, ipk ! dimensions + INTEGER :: iisht, ijsht !!----------------------------------------------------------------------- ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension ipk = K_SIZE(ptab) ! 3rd dimension ! - ztmp = OPER/**/val( ARRAY_IN(:,:,1)*tmask_i(:,:) ) + iisht = ( jpi - ipi ) / 2 + ijsht = ( jpj - ipj ) / 2 ! should be the same as iisht... + ! + ztmp = OPER/**/val( ARRAY_IN(Nis0-iisht:Nie0-iisht,Njs0-ijsht:Nje0-ijsht,1)*tmask_i(Nis0:Nie0,Njs0:Nje0) ) DO jk = 2, ipk - ztmp = OPER/**/(ztmp, OPER/**/val( ARRAY_IN(:,:,jk)*tmask_i(:,:) )) + ztmp = OPER/**/(ztmp, OPER/**/val( ARRAY_IN(Nis0-iisht:Nie0-iisht,Njs0-ijsht:Nje0-ijsht,jk)*tmask_i(Nis0:Nie0,Njs0:Nje0) )) ENDDO CALL mpp_/**/OPER/**/( cdname, ztmp) - glob_/**/OPER/**/_/**/XD = ztmp + glob_/**/OPER/**/_/**/XD = ztmp END FUNCTION glob_/**/OPER/**/_/**/XD #undef XD #undef ARRAY_TYPE -#undef ARRAY2_TYPE #undef ARRAY_IN -#undef ARRAY2_IN #undef K_SIZE #undef OPER # endif diff --git a/src/OCE/par_oce.F90 b/src/OCE/par_oce.F90 index f72dce4489875d625f007354ea52d9c622c951af..f6ef02fe90aa0aa82453f3a9feb8d01d526e8139 100644 --- a/src/OCE/par_oce.F90 +++ b/src/OCE/par_oce.F90 @@ -59,7 +59,8 @@ MODULE par_oce INTEGER, PUBLIC :: jpj ! !: second dimension INTEGER, PUBLIC :: jpk ! = jpkglo !: third dimension INTEGER, PUBLIC :: jpkm1 ! = jpk-1 !: - - - - INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj + !INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj + INTEGER, PUBLIC :: jpij ! = (jpi-2*nn_hls)*(jpj-2*nn_hls) !: jpi x jpj but without the halos INTEGER, PUBLIC :: jpimax! = ( Ni0glo + jpni-1 ) / jpni + 2*nn_hls !: maximum jpi INTEGER, PUBLIC :: jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls !: maximum jpj diff --git a/src/OCE/step.F90 b/src/OCE/step.F90 index ff2759f8c9abfc5bd28d1eb1b36d3e3a00d526f1..d7036efb32e5173bfb9e8495dac631af18c45301 100644 --- a/src/OCE/step.F90 +++ b/src/OCE/step.F90 @@ -174,7 +174,7 @@ CONTAINS ! VERTICAL PHYSICS ! lbc_lnk needed for zdf_sh2 when using nn_hls = 2, moved here to allow tiling in zdf_phy - IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp ) +!!$ IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp ) IF( ln_tile ) CALL dom_tile_start ! [tiling] ZDF tiling loop DO jtile = 1, nijtile diff --git a/src/OCE/stpmlf.F90 b/src/OCE/stpmlf.F90 index bae696704a881cbd31d2ec554ec1d9d6d2fe869c..2afa912fc64cc016f25a1d32619eed38a9ad42d2 100644 --- a/src/OCE/stpmlf.F90 +++ b/src/OCE/stpmlf.F90 @@ -555,7 +555,7 @@ CONTAINS & , pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) ! ! lbc_lnk needed for zdf_sh2 when using nn_hls = 2, moved here to allow tiling in zdf_phy - IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp ) +!!$ IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp ) ! dom_qco_r3c defines over [nn_hls, nn_hls-1, nn_hls, nn_hls-1] IF( nn_hls == 2 .AND. .NOT. lk_linssh ) THEN diff --git a/src/SAS/nemogcm.F90 b/src/SAS/nemogcm.F90 index ce1716e487cbe17cf518fa366ac65b8a90e36812..8e07126365d8773cbedae282431f64f3d001e0b3 100644 --- a/src/SAS/nemogcm.F90 +++ b/src/SAS/nemogcm.F90 @@ -217,7 +217,6 @@ CONTAINS IF( lk_oasis ) THEN ; cxios_context = 'sas' ! when coupling SAS to OCE ELSE ; cxios_context = 'nemo' ! ENDIF - nn_hls = 1 ! l_SAS = .TRUE. ! used in domain:dom_nam ! @@ -390,6 +389,7 @@ CONTAINS #if defined key_agrif uu(:,:,:,:) = 0.0_wp ; vv(:,:,:,:) = 0.0_wp ; ts(:,:,:,:,:) = 0.0_wp ! needed for interp done at initialization phase + uu_b(:,:,:) = 0.0_wp ; vv_b(:,:,:) = 0.0_wp #endif ! ! external forcing CALL sbc_init( Nbb, Nnn, Naa ) ! Forcings : surface module diff --git a/src/SAS/stpctl.F90 b/src/SAS/stpctl.F90 index e5c9a573b1f479e5e829212cfdf802bca3c76617..9ecbe24ba84f9d4e818ea34c96d9450c1cb45b40 100644 --- a/src/SAS/stpctl.F90 +++ b/src/SAS/stpctl.F90 @@ -36,6 +36,9 @@ MODULE stpctl INTEGER, PARAMETER :: jpvar = 3 INTEGER :: nrunid ! netcdf file id INTEGER, DIMENSION(jpvar) :: nvarid ! netcdf variable id + + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/SAS 4.0 , NEMO Consortium (2018) !! $Id: stpctl.F90 14433 2021-02-11 08:06:49Z smasson $ @@ -77,8 +80,8 @@ CONTAINS IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid ! ll_wrtstp = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) - ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1 - ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm + ll_colruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. jpnij > 1 + ll_wrtruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. lwm ! IF( kt == nit000 ) THEN ! @@ -132,7 +135,7 @@ CONTAINS ! zmax(1) = MAXVAL( vt_i (:,:) , mask = llmsk ) ! max ice thickness zmax(2) = MAXVAL( ABS( u_ice(:,:) ) , mask = llmsk ) ! max ice velocity (zonal only) - zmax(3) = MAXVAL( -tm_i (:,:) + rt0, mask = llmsk ) ! min ice temperature (in degC) + zmax(3) = MAXVAL( -tm_i (:,:) + rt0, mask = llmsk(A2D(0)) ) ! min ice temperature (in degC) zmax(jpvar+1) = REAL( nstop, wp ) ! stop indicator ! ! !== get global extrema ==! @@ -172,9 +175,9 @@ CONTAINS ! first: close the netcdf file, so we can read it IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) ! get global loc on the min/max - CALL mpp_maxloc( 'stpctl', vt_i(:,:) , llmsk, zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F - CALL mpp_maxloc( 'stpctl',ABS( u_ice(:,:) ) , llmsk, zzz, iloc(1:2,2) ) - CALL mpp_minloc( 'stpctl', tm_i(:,:) - rt0, llmsk, zzz, iloc(1:2,3) ) + CALL mpp_maxloc( 'stpctl', vt_i(:,:) , llmsk , zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F + CALL mpp_maxloc( 'stpctl',ABS( u_ice(:,:) ) , llmsk , zzz, iloc(1:2,2) ) + CALL mpp_minloc( 'stpctl', tm_i(:,:) - rt0, llmsk(A2D(0)), zzz, iloc(1:2,3) ) ! find which subdomain has the max. iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 DO ji = 1, jptst @@ -187,9 +190,9 @@ CONTAINS CALL mpp_sum( "stpctl", iareasum ) ! sum over the global domain ELSE ! find local min and max locations: ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc - iloc(1:2,1) = MAXLOC( vt_i(:,:) , mask = llmsk ) - iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) ) , mask = llmsk ) - iloc(1:2,3) = MINLOC( tm_i(:,:) - rt0, mask = llmsk ) + iloc(1:2,1) = MAXLOC( vt_i(:,:) , mask = llmsk ) + iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) ) , mask = llmsk ) + iloc(1:2,3) = MINLOC( tm_i(:,:) - rt0, mask = llmsk(A2D(0)) ) DO ji = 1, jptst ! local domain indices ==> global domain indices, excluding halos iloc(1:2,ji) = (/ mig(iloc(1,ji),0), mjg(iloc(2,ji),0) /) END DO diff --git a/src/SWE/stpctl.F90 b/src/SWE/stpctl.F90 index 24e3bef8d1319cc2d6c3bb066194a71c340ef902..f69bb259797631750e9c09e5ffd3aeed474fb94c 100644 --- a/src/SWE/stpctl.F90 +++ b/src/SWE/stpctl.F90 @@ -75,8 +75,8 @@ CONTAINS IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid ! ll_wrtstp = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) - ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1 - ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm + ll_colruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. jpnij > 1 + ll_wrtruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. lwm ! IF( kt == nit000 ) THEN ! diff --git a/tests/BENCH/MY_SRC/usrdef_sbc.F90 b/tests/BENCH/MY_SRC/usrdef_sbc.F90 index ee91c35e0ba6adab4e2f557062e9f55e069488ad..7ad3b70643f185c46892c8c3e62112c8953081d0 100644 --- a/tests/BENCH/MY_SRC/usrdef_sbc.F90 +++ b/tests/BENCH/MY_SRC/usrdef_sbc.F90 @@ -125,7 +125,7 @@ CONTAINS REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness !! - REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing + REAL(wp), DIMENSION(A2D(0)) :: zsnw ! snw distribution after wind blowing !!--------------------------------------------------------------------- #if defined key_si3 ! @@ -150,9 +150,9 @@ CONTAINS emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:) emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) ) qevap_ice(:,:,:) = 0._wp - qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3 - qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp - qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only) + qprec_ice(:,:) = rhos * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! in J/m3 + qemp_oce (:,:) = - emp_oce(:,:) * sst_m(A2D(0)) * rcp + qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! solid precip (only) ! total fluxes emp_tot (:,:) = emp_ice + emp_oce diff --git a/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 b/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 index 6e7c527bf6b2f0361b64717e4c46ca4acd491f2a..5ba2758fdf833f73adb137067238e6437b98bc15 100644 --- a/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 +++ b/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 @@ -18,7 +18,7 @@ MODULE usrdef_sbc USE sbc_ice ! Surface boundary condition: ice fields USE phycst ! physical constants USE ice, ONLY : at_i_b, a_i_b - USE icethd_dh ! for CALL ice_thd_snwblow +!! USE icethd_dh ! for CALL ice_thd_snwblow USE sbc_phy, ONLY : pp_cldf ! USE in_out_manager ! I/O manager @@ -33,6 +33,8 @@ MODULE usrdef_sbc PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) !! $Id: usrdef_sbc.F90 14273 2021-01-06 10:57:45Z smasson $ @@ -109,8 +111,8 @@ CONTAINS !! INTEGER :: jl REAL(wp) :: zfr1, zfr2 ! local variables - REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing - REAL(wp), DIMENSION(jpi,jpj) :: ztri + REAL(wp), DIMENSION(A2D(0)) :: zsnw ! snw distribution after wind blowing + REAL(wp), DIMENSION(A2D(0)) :: ztri !!--------------------------------------------------------------------- ! IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_AGRIF case: NO flux forcing' @@ -134,9 +136,9 @@ CONTAINS emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:) emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) ) qevap_ice(:,:,:) = 0._wp - qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3 - qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp - qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only) + qprec_ice(:,:) = rhos * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! in J/m3 + qemp_oce (:,:) = - emp_oce(:,:) * sst_m(A2D(0)) * rcp + qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! solid precip (only) ! total fluxes emp_tot (:,:) = emp_ice + emp_oce @@ -148,11 +150,11 @@ CONTAINS ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm ! DO jl = 1, jpl - WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm - qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) - ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm + WHERE ( phs(A2D(0),jl) <= 0._wp .AND. phi(A2D(0),jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm + qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(A2D(0),jl) * 10._wp ) ) + ELSEWHERE( phs(A2D(0),jl) <= 0._wp .AND. phi(A2D(0),jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:) - ELSEWHERE ! zero when hs>0 + ELSEWHERE ! zero when hs>0 qtr_ice_top(:,:,jl) = 0._wp END WHERE ENDDO diff --git a/tests/ICE_RHEO/MY_SRC/usrdef_sbc.F90 b/tests/ICE_RHEO/MY_SRC/usrdef_sbc.F90 index 0d9d07e01e46138d0b329587a3dbcb259b120f85..603cb78a3d34b5009d3e20302978fceae1b392d9 100644 --- a/tests/ICE_RHEO/MY_SRC/usrdef_sbc.F90 +++ b/tests/ICE_RHEO/MY_SRC/usrdef_sbc.F90 @@ -108,7 +108,7 @@ CONTAINS REAL(wp) :: zwndi_f , zwndj_f, zwnorm_f ! relative wind module and components at F-point REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point - REAL(wp), DIMENSION(jpi,jpj) :: windu, windv ! wind components (idealised forcing) + REAL(wp), DIMENSION(A2D(0)) :: windu, windv ! wind components (idealised forcing) REAL(wp), PARAMETER :: r_vfac = 1._wp ! relative velocity (make 0 for absolute velocity) REAL(wp), PARAMETER :: Rwind = -0.8_wp ! ratio of wind components REAL(wp), PARAMETER :: Umax = 15._wp ! maximum wind speed (m/s) @@ -140,7 +140,7 @@ CONTAINS utau_ice(ji,jj) = zrhoa * Cd_atm * wndm_ice(ji,jj) * zwndi_t vtau_ice(ji,jj) = zrhoa * Cd_atm * wndm_ice(ji,jj) * zwndj_t END_2D - CALL lbc_lnk( 'usrdef_sbc', wndm_ice, 'T', 1., utau_ice, 'T', -1., vtau_ice, 'T', -1. ) + CALL lbc_lnk( 'usrdef_sbc', utau_ice, 'T', -1., vtau_ice, 'T', -1. ) ! END SUBROUTINE usrdef_sbc_ice_tau @@ -156,7 +156,7 @@ CONTAINS REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness !! REAL(wp) :: zfr1, zfr2 ! local variables - REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing + REAL(wp), DIMENSION(A2D(0)) :: zsnw ! snw distribution after wind blowing !!--------------------------------------------------------------------- ! IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_RHEO case: NO flux forcing' @@ -180,9 +180,9 @@ CONTAINS emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:) emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) ) qevap_ice(:,:,:) = 0._wp - qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3 - qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp - qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only) + qprec_ice(:,:) = rhos * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! in J/m3 + qemp_oce (:,:) = - emp_oce(:,:) * sst_m(A2D(0)) * rcp + qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! solid precip (only) ! total fluxes emp_tot (:,:) = emp_ice + emp_oce @@ -193,11 +193,11 @@ CONTAINS zfr1 = ( 0.18 * ( 1.0 - pp_cldf ) + 0.35 * pp_cldf ) ! transmission when hi>10cm zfr2 = ( 0.82 * ( 1.0 - pp_cldf ) + 0.65 * pp_cldf ) ! zfr2 such that zfr1 + zfr2 to equal 1 ! - WHERE ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm - qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( zfr1 + zfr2 * ( 1._wp - phi(:,:,:) * 10._wp ) ) - ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp ) ! constant (zfr1) when hi>10cm + WHERE ( phs(A2D(0),:) <= 0._wp .AND. phi(A2D(0),:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm + qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( zfr1 + zfr2 * ( 1._wp - phi(A2D(0),:) * 10._wp ) ) + ELSEWHERE( phs(A2D(0),:) <= 0._wp .AND. phi(A2D(0),:) >= 0.1_wp ) ! constant (zfr1) when hi>10cm qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1 - ELSEWHERE ! zero when hs>0 + ELSEWHERE ! zero when hs>0 qtr_ice_top(:,:,:) = 0._wp END WHERE diff --git a/tests/ISOMIP+/EXPREF/namelist_cfg b/tests/ISOMIP+/EXPREF/namelist_cfg index 0b8ae4c942cae45c37a6d6af06a6289e343a890b..4f520bed6b9bf846c87b0c5a80efbbaee91e7d37 100644 --- a/tests/ISOMIP+/EXPREF/namelist_cfg +++ b/tests/ISOMIP+/EXPREF/namelist_cfg @@ -310,14 +310,19 @@ rn_Dt = 720. !----------------------------------------------------------------------- &nameos ! ocean Equation Of Seawater (default: NO selection) !----------------------------------------------------------------------- - ln_leos = .true. ! = Use L-EOS (linear Eq.) - ! + ln_seos = .true. ! = Use S-EOS (simplified Eq.) ! ! S-EOS coefficients (ln_seos=T): ! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS - ! ! L-EOS coefficients (ln_seos=T): - ! ! rd(T,S,Z)*rho0 = rho0*(-a0*dT+b0*dS) + ! ! dT = T-rn_T0 ; dS = S-rn_S0 + rn_T0 = -1. ! reference temperature + rn_S0 = 34.2 ! reference salinity rn_a0 = 3.7330e-5 ! thermal expension coefficient rn_b0 = 7.8430e-4 ! saline expension coefficient + rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos) / !----------------------------------------------------------------------- &namtra_adv ! advection scheme for tracer (default: NO selection) diff --git a/tests/ISOMIP+/MY_SRC/dtatsd.F90 b/tests/ISOMIP+/MY_SRC/dtatsd.F90 index cdee4ac5f65296fbbcdeb83ba0235006dd208c4c..485fae65ce9b57cc1b4fddf6c946fdf92391e0cd 100644 --- a/tests/ISOMIP+/MY_SRC/dtatsd.F90 +++ b/tests/ISOMIP+/MY_SRC/dtatsd.F90 @@ -33,8 +33,8 @@ MODULE dtatsd LOGICAL , PUBLIC :: ln_tsd_init !: T & S data flag LOGICAL , PUBLIC :: ln_tsd_dmp !: internal damping toward input data flag + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsd ! structure of input SST (file informations, fields read) TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsdini ! structure of input SST (file informations, fields read) - TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsddmp ! structure of input SST (file informations, fields read) !! * Substitutions # include "do_loop_substitute.h90" @@ -121,16 +121,16 @@ CONTAINS IF( ln_tsd_dmp ) THEN ! - ALLOCATE( sf_tsddmp(jpts), STAT=ierr0 ) + ALLOCATE( sf_tsd(jpts), STAT=ierr0 ) IF( ierr0 > 0 ) THEN - CALL ctl_stop( 'dta_tsd_init: unable to allocate sf_tsddmp structure' ) ; RETURN + CALL ctl_stop( 'dta_tsd_init: unable to allocate sf_tsd structure' ) ; RETURN ENDIF ! ! dmp file - ALLOCATE( sf_tsddmp(jp_tem)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) - IF( sn_dmpt%ln_tint ) ALLOCATE( sf_tsddmp(jp_tem)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) - ALLOCATE( sf_tsddmp(jp_sal)%fnow(jpi,jpj,jpk) , STAT=ierr2 ) - IF( sn_dmps%ln_tint ) ALLOCATE( sf_tsddmp(jp_sal)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) + ALLOCATE( sf_tsd(jp_tem)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) + IF( sn_dmpt%ln_tint ) ALLOCATE( sf_tsd(jp_tem)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) + ALLOCATE( sf_tsd(jp_sal)%fnow(jpi,jpj,jpk) , STAT=ierr2 ) + IF( sn_dmps%ln_tint ) ALLOCATE( sf_tsd(jp_sal)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) ! IF( ierr0 + ierr1 + ierr2 + ierr3 > 0 ) THEN CALL ctl_stop( 'dta_tsd : unable to allocate T & S dmp data arrays' ) ; RETURN @@ -138,14 +138,14 @@ CONTAINS ! ! ! fill sf_tsd with sn_tem & sn_sal and control print slf_i(jp_tem) = sn_dmpt ; slf_i(jp_sal) = sn_dmps - CALL fld_fill( sf_tsddmp, slf_i, cn_dir, 'dta_tsd', 'Temperature & Salinity dmp data', 'namtsd', no_print ) + CALL fld_fill( sf_tsd, slf_i, cn_dir, 'dta_tsd', 'Temperature & Salinity dmp data', 'namtsd', no_print ) ! ENDIF ! END SUBROUTINE dta_tsd_init - SUBROUTINE dta_tsd( kt, cddta, ptsd ) + SUBROUTINE dta_tsd( kt, ptsd, cddta ) !!---------------------------------------------------------------------- !! *** ROUTINE dta_tsd *** !! @@ -159,45 +159,43 @@ CONTAINS !! !! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! ocean time-step - CHARACTER(LEN=3) , INTENT(in ) :: cddta ! dmp or ini - REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data + INTEGER , INTENT(in ) :: kt ! ocean time-step + REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data + CHARACTER(len=*), OPTIONAL , INTENT(in ) :: cddta ! force the initialization when tradmp is used ! INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers REAL(wp):: zl, zi ! local scalars + LOGICAL :: ll_tsdini REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace !!---------------------------------------------------------------------- ! + ll_tsdini = .FALSE. + IF( PRESENT(cddta) ) ll_tsdini = .TRUE. + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only for the full domain IF( ln_tile ) CALL dom_tile_stop( ldhold=.TRUE. ) ! Use full domain - SELECT CASE(cddta) - CASE('ini') + IF( ll_tsdini ) THEN CALL fld_read( kt, 1, sf_tsdini ) !== read T & S data at kt time step ==! - CASE('dmp') - CALL fld_read( kt, 1, sf_tsddmp ) !== read T & S data at kt time step ==! - CASE DEFAULT - CALL ctl_stop('STOP', 'dta_tsd: cddta case unknown') - END SELECT + ELSE + CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! + ENDIF IF( ln_tile ) CALL dom_tile_start( ldhold=.TRUE. ) ! Revert to tile domain ENDIF ! - SELECT CASE(cddta) - CASE('ini') + IF( ll_tsdini ) THEN DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) ptsd(ji,jj,jk,jp_tem) = sf_tsdini(jp_tem)%fnow(ji,jj,jk) ! NO mask ptsd(ji,jj,jk,jp_sal) = sf_tsdini(jp_sal)%fnow(ji,jj,jk) END_3D - CASE('dmp') + ELSE DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) - ptsd(ji,jj,jk,jp_tem) = sf_tsddmp(jp_tem)%fnow(ji,jj,jk) ! NO mask - ptsd(ji,jj,jk,jp_sal) = sf_tsddmp(jp_sal)%fnow(ji,jj,jk) + ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jk) ! NO mask + ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk) END_3D - CASE DEFAULT - CALL ctl_stop('STOP', 'dta_tsd: cddta case unknown') - END SELECT + ENDIF ! IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! ! @@ -261,8 +259,7 @@ CONTAINS ! ENDIF ! - SELECT CASE(cddta) - CASE('ini') + IF( ll_tsdini ) THEN ! !== deallocate T & S structure ==! ! (data used only for initialisation) IF(lwp) WRITE(numout,*) 'dta_tsd: deallocte T & S arrays as they are only use to initialize the run' @@ -272,7 +269,7 @@ CONTAINS IF( sf_tsdini(jp_sal)%ln_tint ) DEALLOCATE( sf_tsdini(jp_sal)%fdta ) DEALLOCATE( sf_tsdini ) ! the structure itself ! - END SELECT + ENDIF ! END SUBROUTINE dta_tsd diff --git a/tests/ISOMIP+/MY_SRC/eosbn2.F90 b/tests/ISOMIP+/MY_SRC/eosbn2.F90 deleted file mode 100644 index d2da8cfd5976e46e78df5a71aad6279ac86fe21b..0000000000000000000000000000000000000000 --- a/tests/ISOMIP+/MY_SRC/eosbn2.F90 +++ /dev/null @@ -1,2078 +0,0 @@ -MODULE eosbn2 - !!============================================================================== - !! *** MODULE eosbn2 *** - !! Equation Of Seawater : in situ density - Brunt-Vaisala frequency - !!============================================================================== - !! History : OPA ! 1989-03 (O. Marti) Original code - !! 6.0 ! 1994-07 (G. Madec, M. Imbard) add bn2 - !! 6.0 ! 1994-08 (G. Madec) Add Jackett & McDougall eos - !! 7.0 ! 1996-01 (G. Madec) statement function for e3 - !! 8.1 ! 1997-07 (G. Madec) density instead of volumic mass - !! - ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure gradient - !! 8.2 ! 2001-09 (M. Ben Jelloul) bugfix on linear eos - !! NEMO 1.0 ! 2002-10 (G. Madec) add eos_init - !! - ! 2002-11 (G. Madec, A. Bozec) partial step, eos_insitu_2d - !! - ! 2003-08 (G. Madec) F90, free form - !! 3.0 ! 2006-08 (G. Madec) add tfreez function (now eos_fzp function) - !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA - !! - ! 2010-10 (G. Nurser, G. Madec) add alpha/beta used in ldfslp - !! 3.7 ! 2012-03 (F. Roquet, G. Madec) add primitive of alpha and beta used in PE computation - !! - ! 2012-05 (F. Roquet) add Vallis and original JM95 equation of state - !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module - !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80 - !! - ! 2015-06 (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! eos : generic interface of the equation of state - !! eos_insitu : Compute the in situ density - !! eos_insitu_pot: Compute the insitu and surface referenced potential volumic mass - !! eos_insitu_2d : Compute the in situ density for 2d fields - !! bn2 : compute the Brunt-Vaisala frequency - !! eos_pt_from_ct: compute the potential temperature from the Conservative Temperature - !! eos_rab : generic interface of in situ thermal/haline expansion ratio - !! eos_rab_3d : compute in situ thermal/haline expansion ratio - !! eos_rab_2d : compute in situ thermal/haline expansion ratio for 2d fields - !! eos_fzp_2d : freezing temperature for 2d fields - !! eos_fzp_0d : freezing temperature for scalar - !! eos_init : set eos parameters (namelist) - !!---------------------------------------------------------------------- - USE dom_oce ! ocean space and time domain - USE domutl, ONLY : is_tile - USE phycst ! physical constants - USE stopar ! Stochastic T/S fluctuations - USE stopts ! Stochastic T/S fluctuations - ! - USE in_out_manager ! I/O manager - USE lib_mpp ! MPP library - USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) - USE prtctl ! Print control - USE lbclnk ! ocean lateral boundary conditions - USE timing ! Timing - - IMPLICIT NONE - PRIVATE - - ! !! * Interface - INTERFACE eos - MODULE PROCEDURE eos_insitu_New, eos_insitu, eos_insitu_pot, eos_insitu_2d, eos_insitu_pot_2d - END INTERFACE - ! - INTERFACE eos_rab - MODULE PROCEDURE rab_3d, rab_2d, rab_0d - END INTERFACE - ! - INTERFACE eos_fzp - MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d - END INTERFACE - ! - PUBLIC eos ! called by step, istate, tranpc and zpsgrd modules - PUBLIC bn2 ! called by step module - PUBLIC eos_rab ! called by ldfslp, zdfddm, trabbl - PUBLIC eos_pt_from_ct ! called by sbcssm - PUBLIC eos_fzp ! called by traadv_cen2 and sbcice_... modules - PUBLIC eos_pen ! used for pe diagnostics in trdpen module - PUBLIC eos_init ! called by istate module - - ! !!** Namelist nameos ** - LOGICAL , PUBLIC :: ln_TEOS10 - LOGICAL , PUBLIC :: ln_EOS80 - LOGICAL , PUBLIC :: ln_SEOS - LOGICAL , PUBLIC :: ln_LEOS ! determine if linear eos is used - - ! Parameters - LOGICAL , PUBLIC :: l_useCT ! =T in ln_TEOS10=T (i.e. use eos_pt_from_ct to compute sst_m), =F otherwise - INTEGER , PUBLIC :: neos ! Identifier for equation of state used - - INTEGER , PARAMETER :: np_teos10 = -1 ! parameter for using TEOS10 - INTEGER , PARAMETER :: np_eos80 = 0 ! parameter for using EOS80 - INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state - INTEGER , PARAMETER :: np_leos = 2 ! parameter for using linear equation of state (ISOMIP+) - - ! !!! simplified eos coefficients (default value: Vallis 2006) - REAL(wp), PUBLIC :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. - REAL(wp), PUBLIC :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. - REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 - REAL(wp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2 - REAL(wp) :: rn_mu1 = 1.4970e-4_wp ! thermobaric coeff. in T - REAL(wp) :: rn_mu2 = 1.1090e-5_wp ! thermobaric coeff. in S - REAL(wp) :: rn_nu = 2.4341e-3_wp ! cabbeling coeff. in theta*salt - - ! TEOS10/EOS80 parameters - REAL(wp) :: r1_S0, r1_T0, r1_Z0, rdeltaS - - ! EOS parameters - REAL(wp) :: EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600 - REAL(wp) :: EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510 - REAL(wp) :: EOS020 , EOS120 , EOS220 , EOS320 , EOS420 - REAL(wp) :: EOS030 , EOS130 , EOS230 , EOS330 - REAL(wp) :: EOS040 , EOS140 , EOS240 - REAL(wp) :: EOS050 , EOS150 - REAL(wp) :: EOS060 - REAL(wp) :: EOS001 , EOS101 , EOS201 , EOS301 , EOS401 - REAL(wp) :: EOS011 , EOS111 , EOS211 , EOS311 - REAL(wp) :: EOS021 , EOS121 , EOS221 - REAL(wp) :: EOS031 , EOS131 - REAL(wp) :: EOS041 - REAL(wp) :: EOS002 , EOS102 , EOS202 - REAL(wp) :: EOS012 , EOS112 - REAL(wp) :: EOS022 - REAL(wp) :: EOS003 , EOS103 - REAL(wp) :: EOS013 - - ! ALPHA parameters - REAL(wp) :: ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500 - REAL(wp) :: ALP010 , ALP110 , ALP210 , ALP310 , ALP410 - REAL(wp) :: ALP020 , ALP120 , ALP220 , ALP320 - REAL(wp) :: ALP030 , ALP130 , ALP230 - REAL(wp) :: ALP040 , ALP140 - REAL(wp) :: ALP050 - REAL(wp) :: ALP001 , ALP101 , ALP201 , ALP301 - REAL(wp) :: ALP011 , ALP111 , ALP211 - REAL(wp) :: ALP021 , ALP121 - REAL(wp) :: ALP031 - REAL(wp) :: ALP002 , ALP102 - REAL(wp) :: ALP012 - REAL(wp) :: ALP003 - - ! BETA parameters - REAL(wp) :: BET000 , BET100 , BET200 , BET300 , BET400 , BET500 - REAL(wp) :: BET010 , BET110 , BET210 , BET310 , BET410 - REAL(wp) :: BET020 , BET120 , BET220 , BET320 - REAL(wp) :: BET030 , BET130 , BET230 - REAL(wp) :: BET040 , BET140 - REAL(wp) :: BET050 - REAL(wp) :: BET001 , BET101 , BET201 , BET301 - REAL(wp) :: BET011 , BET111 , BET211 - REAL(wp) :: BET021 , BET121 - REAL(wp) :: BET031 - REAL(wp) :: BET002 , BET102 - REAL(wp) :: BET012 - REAL(wp) :: BET003 - - ! PEN parameters - REAL(wp) :: PEN000 , PEN100 , PEN200 , PEN300 , PEN400 - REAL(wp) :: PEN010 , PEN110 , PEN210 , PEN310 - REAL(wp) :: PEN020 , PEN120 , PEN220 - REAL(wp) :: PEN030 , PEN130 - REAL(wp) :: PEN040 - REAL(wp) :: PEN001 , PEN101 , PEN201 - REAL(wp) :: PEN011 , PEN111 - REAL(wp) :: PEN021 - REAL(wp) :: PEN002 , PEN102 - REAL(wp) :: PEN012 - - ! ALPHA_PEN parameters - REAL(wp) :: APE000 , APE100 , APE200 , APE300 - REAL(wp) :: APE010 , APE110 , APE210 - REAL(wp) :: APE020 , APE120 - REAL(wp) :: APE030 - REAL(wp) :: APE001 , APE101 - REAL(wp) :: APE011 - REAL(wp) :: APE002 - - ! BETA_PEN parameters - REAL(wp) :: BPE000 , BPE100 , BPE200 , BPE300 - REAL(wp) :: BPE010 , BPE110 , BPE210 - REAL(wp) :: BPE020 , BPE120 - REAL(wp) :: BPE030 - REAL(wp) :: BPE001 , BPE101 - REAL(wp) :: BPE011 - REAL(wp) :: BPE002 - - !! * Substitutions -# include "do_loop_substitute.h90" -# include "domzgr_substitute.h90" - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: eosbn2.F90 10425 2018-12-19 21:54:16Z smasson $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE eos_insitu_New( pts, Knn, prd ) - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_insitu_New *** - !! - !! ** Purpose : Compute the in situ density (ratio rho/rho0) from - !! potential temperature and salinity using an equation of state - !! selected in the nameos namelist - !! - !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rho0 ) / rho0 - !! with prd in situ density anomaly no units - !! t TEOS10: CT or EOS80: PT Celsius - !! s TEOS10: SA or EOS80: SP TEOS10: g/kg or EOS80: psu - !! z depth meters - !! rho in situ density kg/m^3 - !! rho0 reference density kg/m^3 - !! - !! ln_teos10 : polynomial TEOS-10 equation of state is used for rho(t,s,z). - !! Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celsius, sa=35.5 g/kg - !! - !! ln_eos80 : polynomial EOS-80 equation of state is used for rho(t,s,z). - !! Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celsius, sp=35.5 psu - !! - !! ln_seos : simplified equation of state - !! prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rho0 - !! linear case function of T only: rn_alpha<>0, other coefficients = 0 - !! linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0 - !! Vallis like equation: use default values of coefficients - !! - !! ln_leos : linear ISOMIP equation of state - !! prd(t,s,z) = ( -a0*(T-T0) + b0*(S-S0) ) / rho0 - !! setup for ISOMIP linear eos - !! - !! ** Action : compute prd , the in situ density (no units) - !! - !! References : Roquet et al, Ocean Modelling, in preparation (2014) - !! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006 - !! TEOS-10 Manual, 2010 - !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(:,:,:,:,:), INTENT(in ) :: pts ! T-S - INTEGER , INTENT(in ) :: Knn ! time-level - REAL(wp), DIMENSION(:,:,: ), INTENT( out) :: prd ! in situ density - ! - INTEGER :: ji, jj, jk ! dummy loop indices - REAL(wp) :: zt , zh , zs , ztm ! local scalars - REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('eos-insitu') - ! - SELECT CASE( neos ) - ! - CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! - ! - DO_3D(nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - ! - zh = gdept(ji,jj,jk,Knn) * r1_Z0 ! depth - zt = pts (ji,jj,jk,jp_tem,Knn) * r1_T0 ! temperature - zs = SQRT( ABS( pts(ji,jj,jk,jp_sal,Knn) + rdeltaS ) * r1_S0 ) ! square root salinity - ztm = tmask(ji,jj,jk) ! tmask - ! - zn3 = EOS013*zt & - & + EOS103*zs+EOS003 - ! - zn2 = (EOS022*zt & - & + EOS112*zs+EOS012)*zt & - & + (EOS202*zs+EOS102)*zs+EOS002 - ! - zn1 = (((EOS041*zt & - & + EOS131*zs+EOS031)*zt & - & + (EOS221*zs+EOS121)*zs+EOS021)*zt & - & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & - & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 - ! - zn0 = (((((EOS060*zt & - & + EOS150*zs+EOS050)*zt & - & + (EOS240*zs+EOS140)*zs+EOS040)*zt & - & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & - & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & - & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & - & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked) - ! - END_3D - ! - CASE( np_seos ) !== simplified EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem,Knn) - 10._wp - zs = pts (ji,jj,jk,jp_sal,Knn) - 35._wp - zh = gdept(ji,jj,jk,Knn) - ztm = tmask(ji,jj,jk) - ! - zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & - & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & - & - rn_nu * zt * zs - ! - prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked) - END_3D - ! - CASE( np_leos ) !== linear ISOMIP EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem,Knn) - (-1._wp) - zs = pts (ji,jj,jk,jp_sal,Knn) - 34.2_wp - zh = gdept(ji,jj,jk, Knn) - ztm = tmask(ji,jj,jk) - ! - zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs ) - ! - prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked) - END_3D - ! - END SELECT - ! - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', kdim=jpk ) - ! - IF( ln_timing ) CALL timing_stop('eos-insitu') - ! - END SUBROUTINE eos_insitu_New - - - SUBROUTINE eos_insitu( pts, prd, pdep ) - !! - REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] - ! ! 2 : salinity [psu] - REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] - REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] - !! - CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) ) - END SUBROUTINE eos_insitu - - SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep ) - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_insitu *** - !! - !! ** Purpose : Compute the in situ density (ratio rho/rho0) from - !! potential temperature and salinity using an equation of state - !! selected in the nameos namelist - !! - !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rho0 ) / rho0 - !! with prd in situ density anomaly no units - !! t TEOS10: CT or EOS80: PT Celsius - !! s TEOS10: SA or EOS80: SP TEOS10: g/kg or EOS80: psu - !! z depth meters - !! rho in situ density kg/m^3 - !! rho0 reference density kg/m^3 - !! - !! ln_teos10 : polynomial TEOS-10 equation of state is used for rho(t,s,z). - !! Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celsius, sa=35.5 g/kg - !! - !! ln_eos80 : polynomial EOS-80 equation of state is used for rho(t,s,z). - !! Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celsius, sp=35.5 psu - !! - !! ln_seos : simplified equation of state - !! prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rho0 - !! linear case function of T only: rn_alpha<>0, other coefficients = 0 - !! linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0 - !! Vallis like equation: use default values of coefficients - !! - !! ln_leos : linear ISOMIP equation of state - !! prd(t,s,z) = ( -a0*(T-T0) + b0*(S-S0) ) / rho0 - !! setup for ISOMIP linear eos - !! - !! ** Action : compute prd , the in situ density (no units) - !! - !! References : Roquet et al, Ocean Modelling, in preparation (2014) - !! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006 - !! TEOS-10 Manual, 2010 - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: ktts, ktrd, ktdep - REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] - ! ! 2 : salinity [psu] - REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] - REAL(wp), DIMENSION(A2D_T(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m] - ! - INTEGER :: ji, jj, jk ! dummy loop indices - REAL(wp) :: zt , zh , zs , ztm ! local scalars - REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('eos-insitu') - ! - SELECT CASE( neos ) - ! - CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - ! - zh = pdep(ji,jj,jk) * r1_Z0 ! depth - zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature - zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity - ztm = tmask(ji,jj,jk) ! tmask - ! - zn3 = EOS013*zt & - & + EOS103*zs+EOS003 - ! - zn2 = (EOS022*zt & - & + EOS112*zs+EOS012)*zt & - & + (EOS202*zs+EOS102)*zs+EOS002 - ! - zn1 = (((EOS041*zt & - & + EOS131*zs+EOS031)*zt & - & + (EOS221*zs+EOS121)*zs+EOS021)*zt & - & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & - & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 - ! - zn0 = (((((EOS060*zt & - & + EOS150*zs+EOS050)*zt & - & + (EOS240*zs+EOS140)*zs+EOS040)*zt & - & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & - & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & - & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & - & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked) - ! - END_3D - ! - CASE( np_seos ) !== simplified EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem) - 10._wp - zs = pts (ji,jj,jk,jp_sal) - 35._wp - zh = pdep (ji,jj,jk) - ztm = tmask(ji,jj,jk) - ! - zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & - & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & - & - rn_nu * zt * zs - ! - prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked) - END_3D - ! - CASE( np_leos ) !== linear ISOMIP EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem) - (-1._wp) - zs = pts (ji,jj,jk,jp_sal) - 34.2_wp - zh = pdep (ji,jj,jk) - ztm = tmask(ji,jj,jk) - ! - zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs ) - ! - prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked) - END_3D - ! - END SELECT - ! - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', kdim=jpk ) - ! - IF( ln_timing ) CALL timing_stop('eos-insitu') - ! - END SUBROUTINE eos_insitu_t - - - SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) - !! - REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] - ! ! 2 : salinity [psu] - REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] - REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced) - REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] - !! - CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) ) - END SUBROUTINE eos_insitu_pot - - - SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep ) - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_insitu_pot *** - !! - !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the - !! potential volumic mass (Kg/m3) from potential temperature and - !! salinity fields using an equation of state selected in the - !! namelist. - !! - !! ** Action : - prd , the in situ density (no units) - !! - prhop, the potential volumic mass (Kg/m3) - !! - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep - REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] - ! ! 2 : salinity [psu] - REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] - REAL(wp), DIMENSION(A2D_T(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced) - REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m] - ! - INTEGER :: ji, jj, jk, jsmp ! dummy loop indices - INTEGER :: jdof - REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars - REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - - REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('eos-pot') - ! - SELECT CASE ( neos ) - ! - CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! - ! - ! Stochastic equation of state - IF ( ln_sto_eos ) THEN - ALLOCATE(zn0_sto(1:2*nn_sto_eos)) - ALLOCATE(zn_sto(1:2*nn_sto_eos)) - ALLOCATE(zsign(1:2*nn_sto_eos)) - DO jsmp = 1, 2*nn_sto_eos, 2 - zsign(jsmp) = 1._wp - zsign(jsmp+1) = -1._wp - END DO - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - ! - ! compute density (2*nn_sto_eos) times: - ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) - ! (2) for t-dt, s-ds (with the opposite fluctuation) - DO jsmp = 1, nn_sto_eos*2 - jdof = (jsmp + 1) / 2 - zh = pdep(ji,jj,jk) * r1_Z0 ! depth - zt = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0 ! temperature - zstemp = pts (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) - zs = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 ) ! square root salinity - ztm = tmask(ji,jj,jk) ! tmask - ! - zn3 = EOS013*zt & - & + EOS103*zs+EOS003 - ! - zn2 = (EOS022*zt & - & + EOS112*zs+EOS012)*zt & - & + (EOS202*zs+EOS102)*zs+EOS002 - ! - zn1 = (((EOS041*zt & - & + EOS131*zs+EOS031)*zt & - & + (EOS221*zs+EOS121)*zs+EOS021)*zt & - & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & - & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 - ! - zn0_sto(jsmp) = (((((EOS060*zt & - & + EOS150*zs+EOS050)*zt & - & + (EOS240*zs+EOS140)*zs+EOS040)*zt & - & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & - & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & - & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & - & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 - ! - zn_sto(jsmp) = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) - END DO - ! - ! compute stochastic density as the mean of the (2*nn_sto_eos) densities - prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp - DO jsmp = 1, nn_sto_eos*2 - prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp) ! potential density referenced at the surface - ! - prd(ji,jj,jk) = prd(ji,jj,jk) + ( zn_sto(jsmp) * r1_rho0 - 1._wp ) ! density anomaly (masked) - END DO - prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos - prd (ji,jj,jk) = 0.5_wp * prd (ji,jj,jk) * ztm / nn_sto_eos - END_3D - DEALLOCATE(zn0_sto,zn_sto,zsign) - ! Non-stochastic equation of state - ELSE - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - ! - zh = pdep(ji,jj,jk) * r1_Z0 ! depth - zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature - zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity - ztm = tmask(ji,jj,jk) ! tmask - ! - zn3 = EOS013*zt & - & + EOS103*zs+EOS003 - ! - zn2 = (EOS022*zt & - & + EOS112*zs+EOS012)*zt & - & + (EOS202*zs+EOS102)*zs+EOS002 - ! - zn1 = (((EOS041*zt & - & + EOS131*zs+EOS031)*zt & - & + (EOS221*zs+EOS121)*zs+EOS021)*zt & - & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & - & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 - ! - zn0 = (((((EOS060*zt & - & + EOS150*zs+EOS050)*zt & - & + (EOS240*zs+EOS140)*zs+EOS040)*zt & - & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & - & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & - & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & - & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface - ! - prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked) - END_3D - ENDIF - - CASE( np_seos ) !== simplified EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem) - 10._wp - zs = pts (ji,jj,jk,jp_sal) - 35._wp - zh = pdep (ji,jj,jk) - ztm = tmask(ji,jj,jk) - ! ! potential density referenced at the surface - zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & - & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & - & - rn_nu * zt * zs - prhop(ji,jj,jk) = ( rho0 + zn ) * ztm - ! ! density anomaly (masked) - zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh - prd(ji,jj,jk) = zn * r1_rho0 * ztm - ! - END_3D - ! - CASE( np_leos ) !== linear ISOMIP EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem) - (-1._wp) - zs = pts (ji,jj,jk,jp_sal) - 34.2_wp - zh = pdep (ji,jj,jk) - ztm = tmask(ji,jj,jk) - ! ! potential density referenced at the surface - zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs ) - prhop(ji,jj,jk) = ( rho0 + zn ) * ztm - ! ! density anomaly (masked) - prd(ji,jj,jk) = zn * r1_rho0 * ztm - ! - END_3D - ! - END SELECT - ! - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', & - & tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) - ! - IF( ln_timing ) CALL timing_stop('eos-pot') - ! - END SUBROUTINE eos_insitu_pot_t - - - SUBROUTINE eos_insitu_2d( pts, pdep, prd ) - !! - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] - ! ! 2 : salinity [psu] - REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] - REAL(wp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density - !! - CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) ) - END SUBROUTINE eos_insitu_2d - - - SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd ) - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_insitu_2d *** - !! - !! ** Purpose : Compute the in situ density (ratio rho/rho0) from - !! potential temperature and salinity using an equation of state - !! selected in the nameos namelist. * 2D field case - !! - !! ** Action : - prd , the in situ density (no units) (unmasked) - !! - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: ktts, ktdep, ktrd - REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] - ! ! 2 : salinity [psu] - REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] - REAL(wp), DIMENSION(A2D_T(ktrd) ), INTENT( out) :: prd ! in situ density - ! - INTEGER :: ji, jj, jk ! dummy loop indices - REAL(wp) :: zt , zh , zs ! local scalars - REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('eos2d') - ! - prd(:,:) = 0._wp - ! - SELECT CASE( neos ) - ! - CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! - zh = pdep(ji,jj) * r1_Z0 ! depth - zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature - zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity - ! - zn3 = EOS013*zt & - & + EOS103*zs+EOS003 - ! - zn2 = (EOS022*zt & - & + EOS112*zs+EOS012)*zt & - & + (EOS202*zs+EOS102)*zs+EOS002 - ! - zn1 = (((EOS041*zt & - & + EOS131*zs+EOS031)*zt & - & + (EOS221*zs+EOS121)*zs+EOS021)*zt & - & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & - & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 - ! - zn0 = (((((EOS060*zt & - & + EOS150*zs+EOS050)*zt & - & + (EOS240*zs+EOS140)*zs+EOS040)*zt & - & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & - & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & - & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & - & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - prd(ji,jj) = zn * r1_rho0 - 1._wp ! unmasked in situ density anomaly - ! - END_2D - ! - CASE( np_seos ) !== simplified EOS ==! - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! - zt = pts (ji,jj,jp_tem) - 10._wp - zs = pts (ji,jj,jp_sal) - 35._wp - zh = pdep (ji,jj) ! depth at the partial step level - ! - zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & - & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & - & - rn_nu * zt * zs - ! - prd(ji,jj) = zn * r1_rho0 ! unmasked in situ density anomaly - ! - END_2D - ! - CASE( np_leos ) !== ISOMIP EOS ==! - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! - zt = pts (ji,jj,jp_tem) - (-1._wp) - zs = pts (ji,jj,jp_sal) - 34.2_wp - zh = pdep (ji,jj) ! depth at the partial step level - ! - zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs ) - ! - prd(ji,jj) = zn * r1_rho0 ! unmasked in situ density anomaly - ! - END_2D - ! - ! - END SELECT - ! - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) - ! - IF( ln_timing ) CALL timing_stop('eos2d') - ! - END SUBROUTINE eos_insitu_2d_t - - - SUBROUTINE eos_insitu_pot_2d( pts, prhop ) - !! - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] - ! ! 2 : salinity [psu] - REAL(wp), DIMENSION(:,:) , INTENT( out) :: prhop ! potential density (surface referenced) - !! - CALL eos_insitu_pot_2d_t( pts, is_tile(pts), prhop, is_tile(prhop) ) - END SUBROUTINE eos_insitu_pot_2d - - - SUBROUTINE eos_insitu_pot_2d_t( pts, ktts, prhop, ktrhop ) - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_insitu_pot *** - !! - !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the - !! potential volumic mass (Kg/m3) from potential temperature and - !! salinity fields using an equation of state selected in the - !! namelist. - !! - !! ** Action : - !! - prhop, the potential volumic mass (Kg/m3) - !! - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: ktts, ktrhop - REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] - ! ! 2 : salinity [psu] - REAL(wp), DIMENSION(A2D_T(ktrhop) ), INTENT( out) :: prhop ! potential density (surface referenced) - ! - INTEGER :: ji, jj, jk, jsmp ! dummy loop indices - INTEGER :: jdof - REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars - REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - - REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('eos-pot') - ! - SELECT CASE ( neos ) - ! - CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! - zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature - zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity - ztm = tmask(ji,jj,1) ! tmask - ! - zn0 = (((((EOS060*zt & - & + EOS150*zs+EOS050)*zt & - & + (EOS240*zs+EOS140)*zs+EOS040)*zt & - & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & - & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & - & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & - & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 - ! - ! - prhop(ji,jj) = zn0 * ztm ! potential density referenced at the surface - ! - END_2D - - CASE( np_seos ) !== simplified EOS ==! - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - zt = pts (ji,jj,jp_tem) - 10._wp - zs = pts (ji,jj,jp_sal) - 35._wp - ztm = tmask(ji,jj,1) - ! ! potential density referenced at the surface - zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & - & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & - & - rn_nu * zt * zs - prhop(ji,jj) = ( rho0 + zn ) * ztm - ! - END_2D - ! - CASE( np_leos ) !== ISOMIP EOS ==! - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! - zt = pts (ji,jj,jp_tem) - (-1._wp) - zs = pts (ji,jj,jp_sal) - 34.2_wp - !zh = pdep (ji,jj) ! depth at the partial step level - ! - zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs ) - ! - prhop(ji,jj) = zn * r1_rho0 ! unmasked in situ density anomaly - ! - END_2D - ! - END SELECT - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' pot: ', kdim=1 ) - ! - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' eos-pot: ' ) - ! - IF( ln_timing ) CALL timing_stop('eos-pot') - ! - END SUBROUTINE eos_insitu_pot_2d_t - - - SUBROUTINE rab_3d( pts, pab, Kmm ) - !! - INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio - !! - CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) - END SUBROUTINE rab_3d - - - SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) - !!---------------------------------------------------------------------- - !! *** ROUTINE rab_3d *** - !! - !! ** Purpose : Calculates thermal/haline expansion ratio at T-points - !! - !! ** Method : calculates alpha / beta at T-points - !! - !! ** Action : - pab : thermal/haline expansion ratio at T-points - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: Kmm ! time level index - INTEGER , INTENT(in ) :: ktts, ktab - REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio - ! - INTEGER :: ji, jj, jk ! dummy loop indices - REAL(wp) :: zt , zh , zs , ztm ! local scalars - REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('rab_3d') - ! - SELECT CASE ( neos ) - ! - CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - ! - zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth - zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature - zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity - ztm = tmask(ji,jj,jk) ! tmask - ! - ! alpha - zn3 = ALP003 - ! - zn2 = ALP012*zt + ALP102*zs+ALP002 - ! - zn1 = ((ALP031*zt & - & + ALP121*zs+ALP021)*zt & - & + (ALP211*zs+ALP111)*zs+ALP011)*zt & - & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 - ! - zn0 = ((((ALP050*zt & - & + ALP140*zs+ALP040)*zt & - & + (ALP230*zs+ALP130)*zs+ALP030)*zt & - & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & - & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & - & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm - ! - ! beta - zn3 = BET003 - ! - zn2 = BET012*zt + BET102*zs+BET002 - ! - zn1 = ((BET031*zt & - & + BET121*zs+BET021)*zt & - & + (BET211*zs+BET111)*zs+BET011)*zt & - & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 - ! - zn0 = ((((BET050*zt & - & + BET140*zs+BET040)*zt & - & + (BET230*zs+BET130)*zs+BET030)*zt & - & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & - & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & - & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - pab(ji,jj,jk,jp_sal) = zn / zs * r1_rho0 * ztm - ! - END_3D - ! - CASE( np_seos ) !== simplified EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) - zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) - zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point - ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask - ! - zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs - pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm ! alpha - ! - zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt - pab(ji,jj,jk,jp_sal) = zn * r1_rho0 * ztm ! beta - ! - END_3D - ! - CASE( np_leos ) !== linear ISOMIP EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts (ji,jj,jk,jp_tem) - (-1._wp) - zs = pts (ji,jj,jk,jp_sal) - 34.2_wp ! abs. salinity anomaly (s-S0) - zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point - ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask - ! - zn = rn_a0 * rho0 - pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm ! alpha - ! - zn = rn_b0 * rho0 - pab(ji,jj,jk,jp_sal) = zn * r1_rho0 * ztm ! beta - ! - END_3D - ! - CASE DEFAULT - WRITE(ctmp1,*) ' bad flag value for neos = ', neos - CALL ctl_stop( 'rab_3d:', ctmp1 ) - ! - END SELECT - ! - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & - & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', kdim=jpk ) - ! - IF( ln_timing ) CALL timing_stop('rab_3d') - ! - END SUBROUTINE rab_3d_t - - - SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) - !! - INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] - REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio - !! - CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) - END SUBROUTINE rab_2d - - - SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) - !!---------------------------------------------------------------------- - !! *** ROUTINE rab_2d *** - !! - !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) - !! - !! ** Action : - pab : thermal/haline expansion ratio at T-points - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: Kmm ! time level index - INTEGER , INTENT(in ) :: ktts, ktdep, ktab - REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] - REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio - ! - INTEGER :: ji, jj, jk ! dummy loop indices - REAL(wp) :: zt , zh , zs ! local scalars - REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('rab_2d') - ! - pab(:,:,:) = 0._wp - ! - SELECT CASE ( neos ) - ! - CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! - zh = pdep(ji,jj) * r1_Z0 ! depth - zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature - zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity - ! - ! alpha - zn3 = ALP003 - ! - zn2 = ALP012*zt + ALP102*zs+ALP002 - ! - zn1 = ((ALP031*zt & - & + ALP121*zs+ALP021)*zt & - & + (ALP211*zs+ALP111)*zs+ALP011)*zt & - & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 - ! - zn0 = ((((ALP050*zt & - & + ALP140*zs+ALP040)*zt & - & + (ALP230*zs+ALP130)*zs+ALP030)*zt & - & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & - & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & - & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - pab(ji,jj,jp_tem) = zn * r1_rho0 - ! - ! beta - zn3 = BET003 - ! - zn2 = BET012*zt + BET102*zs+BET002 - ! - zn1 = ((BET031*zt & - & + BET121*zs+BET021)*zt & - & + (BET211*zs+BET111)*zs+BET011)*zt & - & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 - ! - zn0 = ((((BET050*zt & - & + BET140*zs+BET040)*zt & - & + (BET230*zs+BET130)*zs+BET030)*zt & - & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & - & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & - & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - pab(ji,jj,jp_sal) = zn / zs * r1_rho0 - ! - ! - END_2D - ! - CASE( np_seos ) !== simplified EOS ==! - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! - zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) - zs = pts (ji,jj,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) - zh = pdep (ji,jj) ! depth at the partial step level - ! - zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs - pab(ji,jj,jp_tem) = zn * r1_rho0 ! alpha - ! - zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt - pab(ji,jj,jp_sal) = zn * r1_rho0 ! beta - ! - END_2D - ! - CASE( np_leos ) !== linear ISOMIP EOS ==! - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! - zt = pts (ji,jj,jp_tem) - (-1._wp) ! pot. temperature anomaly (t-T0) - zs = pts (ji,jj,jp_sal) - 34.2_wp ! abs. salinity anomaly (s-S0) - zh = pdep (ji,jj) ! depth at the partial step level - ! - zn = rn_a0 * rho0 - pab(ji,jj,jp_tem) = zn * r1_rho0 ! alpha - ! - zn = rn_b0 * rho0 - pab(ji,jj,jp_sal) = zn * r1_rho0 ! beta - ! - END_2D - ! - CASE DEFAULT - WRITE(ctmp1,*) ' bad flag value for neos = ', neos - CALL ctl_stop( 'rab_2d:', ctmp1 ) - ! - END SELECT - ! - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & - & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) - ! - IF( ln_timing ) CALL timing_stop('rab_2d') - ! - END SUBROUTINE rab_2d_t - - - SUBROUTINE rab_0d( pts, pdep, pab, Kmm ) - !!---------------------------------------------------------------------- - !! *** ROUTINE rab_0d *** - !! - !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) - !! - !! ** Action : - pab : thermal/haline expansion ratio at T-points - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(wp), DIMENSION(jpts) , INTENT(in ) :: pts ! pot. temperature & salinity - REAL(wp), INTENT(in ) :: pdep ! depth [m] - REAL(wp), DIMENSION(jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio - ! - REAL(wp) :: zt , zh , zs ! local scalars - REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('rab_0d') - ! - pab(:) = 0._wp - ! - SELECT CASE ( neos ) - ! - CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! - ! - ! - zh = pdep * r1_Z0 ! depth - zt = pts (jp_tem) * r1_T0 ! temperature - zs = SQRT( ABS( pts(jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity - ! - ! alpha - zn3 = ALP003 - ! - zn2 = ALP012*zt + ALP102*zs+ALP002 - ! - zn1 = ((ALP031*zt & - & + ALP121*zs+ALP021)*zt & - & + (ALP211*zs+ALP111)*zs+ALP011)*zt & - & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 - ! - zn0 = ((((ALP050*zt & - & + ALP140*zs+ALP040)*zt & - & + (ALP230*zs+ALP130)*zs+ALP030)*zt & - & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & - & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & - & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - pab(jp_tem) = zn * r1_rho0 - ! - ! beta - zn3 = BET003 - ! - zn2 = BET012*zt + BET102*zs+BET002 - ! - zn1 = ((BET031*zt & - & + BET121*zs+BET021)*zt & - & + (BET211*zs+BET111)*zs+BET011)*zt & - & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 - ! - zn0 = ((((BET050*zt & - & + BET140*zs+BET040)*zt & - & + (BET230*zs+BET130)*zs+BET030)*zt & - & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & - & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & - & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 - ! - zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 - ! - pab(jp_sal) = zn / zs * r1_rho0 - ! - ! - ! - CASE( np_seos ) !== simplified EOS ==! - ! - zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) - zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) - zh = pdep ! depth at the partial step level - ! - zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs - pab(jp_tem) = zn * r1_rho0 ! alpha - ! - zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt - pab(jp_sal) = zn * r1_rho0 ! beta - ! - CASE( np_leos ) !== linear ISOMIP EOS ==! - ! - zt = pts(jp_tem) - (-1._wp) ! pot. temperature anomaly (t-T0) - zs = pts(jp_sal) - 34.2_wp ! abs. salinity anomaly (s-S0) - zh = pdep ! depth at the partial step level - ! - zn = rn_a0 * rho0 - pab(jp_tem) = zn * r1_rho0 ! alpha - ! - zn = rn_b0 * rho0 - pab(jp_sal) = zn * r1_rho0 ! beta - ! - CASE DEFAULT - WRITE(ctmp1,*) ' bad flag value for neos = ', neos - CALL ctl_stop( 'rab_0d:', ctmp1 ) - ! - END SELECT - ! - IF( ln_timing ) CALL timing_stop('rab_0d') - ! - END SUBROUTINE rab_0d - - - SUBROUTINE bn2( pts, pab, pn2, Kmm ) - !! - INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] - REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] - REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] - !! - CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) - END SUBROUTINE bn2 - - - SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) - !!---------------------------------------------------------------------- - !! *** ROUTINE bn2 *** - !! - !! ** Purpose : Compute the local Brunt-Vaisala frequency at the - !! time-step of the input arguments - !! - !! ** Method : pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w - !! where alpha and beta are given in pab, and computed on T-points. - !! N.B. N^2 is set one for all to zero at jk=1 in istate module. - !! - !! ** Action : pn2 : square of the brunt-vaisala frequency at w-point - !! - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: Kmm ! time level index - INTEGER , INTENT(in ) :: ktab, ktn2 - REAL(wp), DIMENSION(jpi,jpj, jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] - REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] - REAL(wp), DIMENSION(A2D_T(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] - ! - INTEGER :: ji, jj, jk ! dummy loop indices - REAL(wp) :: zaw, zbw, zrw ! local scalars - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('bn2') - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 - zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & - & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) ) - ! - zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw - zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw - ! - pn2(ji,jj,jk) = grav * ( zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & - & - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) & - & / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) - END_3D - ! - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', kdim=jpk ) - ! - IF( ln_timing ) CALL timing_stop('bn2') - ! - END SUBROUTINE bn2_t - - - FUNCTION eos_pt_from_ct( ctmp, psal ) RESULT( ptmp ) - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_pt_from_ct *** - !! - !! ** Purpose : Compute pot.temp. from cons. temp. [Celsius] - !! - !! ** Method : rational approximation (5/3th order) of TEOS-10 algorithm - !! checkvalue: pt=20.02391895 Celsius for sa=35.7g/kg, ct=20degC - !! - !! Reference : TEOS-10, UNESCO - !! Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC) - !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celsius] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] - ! Leave result array automatic rather than making explicitly allocated - REAL(wp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celsius] - ! - INTEGER :: ji, jj ! dummy loop indices - REAL(wp) :: zt , zs , ztm ! local scalars - REAL(wp) :: zn , zd ! local scalars - REAL(wp) :: zdeltaS , z1_S0 , z1_T0 - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('eos_pt_from_ct') - ! - zdeltaS = 5._wp - z1_S0 = 0.875_wp/35.16504_wp - z1_T0 = 1._wp/40._wp - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! - zt = ctmp (ji,jj) * z1_T0 - zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * z1_S0 ) - ztm = tmask(ji,jj,1) - ! - zn = ((((-2.1385727895e-01_wp*zt & - & - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt & - & + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt & - & + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt & - & + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs & - & +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt & - & + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs & - & -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp - ! - zd = (2.0035003456_wp*zt & - & -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt & - & + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp - ! - ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm - ! - END_2D - ! - IF( ln_timing ) CALL timing_stop('eos_pt_from_ct') - ! - END FUNCTION eos_pt_from_ct - - - SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) - !! - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] - REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius] - !! - CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) - END SUBROUTINE eos_fzp_2d - - - SUBROUTINE eos_fzp_2d_t( psal, ptf, kttf, pdep ) - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_fzp *** - !! - !! ** Purpose : Compute the freezing point temperature [Celsius] - !! - !! ** Method : UNESCO freezing point (ptf) in Celsius is given by - !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z - !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m - !! - !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kttf - REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu] - REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ), OPTIONAL :: pdep ! depth [m] - REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius] - ! - INTEGER :: ji, jj ! dummy loop indices - REAL(wp) :: zt, zs, z1_S0 ! local scalars - !!---------------------------------------------------------------------- - ! - SELECT CASE ( neos ) - ! - CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==! - ! - z1_S0 = 1._wp / 35.16504_wp - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 ) ! square root salinity - ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & - & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp - END_2D - ptf(:,:) = ptf(:,:) * psal(:,:) - ! - IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) - ! - CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! - ! - ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) & - & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:) - ! - IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) - ! - CASE DEFAULT - WRITE(ctmp1,*) ' bad flag value for neos = ', neos - CALL ctl_stop( 'eos_fzp_2d:', ctmp1 ) - ! - END SELECT - ! - END SUBROUTINE eos_fzp_2d_t - - - SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_fzp *** - !! - !! ** Purpose : Compute the freezing point temperature [Celsius] - !! - !! ** Method : UNESCO freezing point (ptf) in Celsius is given by - !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z - !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m - !! - !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 - !!---------------------------------------------------------------------- - REAL(wp), INTENT(in ) :: psal ! salinity [psu] - REAL(wp), INTENT(in ), OPTIONAL :: pdep ! depth [m] - REAL(wp), INTENT(out) :: ptf ! freezing temperature [Celsius] - ! - REAL(wp) :: zs ! local scalars - !!---------------------------------------------------------------------- - ! - SELECT CASE ( neos ) - ! - CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==! - ! - zs = SQRT( ABS( psal ) / 35.16504_wp ) ! square root salinity - ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & - & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp - ptf = ptf * psal - ! - IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep - ! - CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! - ! - ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal ) & - & - 2.154996e-4_wp * psal ) * psal - ! - IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep - ! - CASE DEFAULT - WRITE(ctmp1,*) ' bad flag value for neos = ', neos - CALL ctl_stop( 'eos_fzp_0d:', ctmp1 ) - ! - END SELECT - ! - END SUBROUTINE eos_fzp_0d - - - SUBROUTINE eos_pen( pts, pab_pe, ppen, Kmm ) - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_pen *** - !! - !! ** Purpose : Calculates nonlinear anomalies of alpha_PE, beta_PE and PE at T-points - !! - !! ** Method : PE is defined analytically as the vertical - !! primitive of EOS times -g integrated between 0 and z>0. - !! pen is the nonlinear bsq-PE anomaly: pen = ( PE - rho0 gz ) / rho0 gz - rd - !! = 1/z * /int_0^z rd dz - rd - !! where rd is the density anomaly (see eos_rhd function) - !! ab_pe are partial derivatives of PE anomaly with respect to T and S: - !! ab_pe(1) = - 1/(rho0 gz) * dPE/dT + drd/dT = - d(pen)/dT - !! ab_pe(2) = 1/(rho0 gz) * dPE/dS + drd/dS = d(pen)/dS - !! - !! ** Action : - pen : PE anomaly given at T-points - !! : - pab_pe : given at T-points - !! pab_pe(:,:,:,jp_tem) is alpha_pe - !! pab_pe(:,:,:,jp_sal) is beta_pe - !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe - REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly - ! - INTEGER :: ji, jj, jk ! dummy loop indices - REAL(wp) :: zt , zh , zs , ztm ! local scalars - REAL(wp) :: zn , zn0, zn1, zn2 ! - - - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('eos_pen') - ! - SELECT CASE ( neos ) - ! - CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - ! - zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth - zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature - zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity - ztm = tmask(ji,jj,jk) ! tmask - ! - ! potential energy non-linear anomaly - zn2 = (PEN012)*zt & - & + PEN102*zs+PEN002 - ! - zn1 = ((PEN021)*zt & - & + PEN111*zs+PEN011)*zt & - & + (PEN201*zs+PEN101)*zs+PEN001 - ! - zn0 = ((((PEN040)*zt & - & + PEN130*zs+PEN030)*zt & - & + (PEN220*zs+PEN120)*zs+PEN020)*zt & - & + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt & - & + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 - ! - zn = ( zn2 * zh + zn1 ) * zh + zn0 - ! - ppen(ji,jj,jk) = zn * zh * r1_rho0 * ztm - ! - ! alphaPE non-linear anomaly - zn2 = APE002 - ! - zn1 = (APE011)*zt & - & + APE101*zs+APE001 - ! - zn0 = (((APE030)*zt & - & + APE120*zs+APE020)*zt & - & + (APE210*zs+APE110)*zs+APE010)*zt & - & + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 - ! - zn = ( zn2 * zh + zn1 ) * zh + zn0 - ! - pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rho0 * ztm - ! - ! betaPE non-linear anomaly - zn2 = BPE002 - ! - zn1 = (BPE011)*zt & - & + BPE101*zs+BPE001 - ! - zn0 = (((BPE030)*zt & - & + BPE120*zs+BPE020)*zt & - & + (BPE210*zs+BPE110)*zs+BPE010)*zt & - & + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 - ! - zn = ( zn2 * zh + zn1 ) * zh + zn0 - ! - pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rho0 * ztm - ! - END_3D - ! - CASE( np_seos ) !== Vallis (2006) simplified EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts(ji,jj,jk,jp_tem) - 10._wp ! temperature anomaly (t-T0) - zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) - zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point - ztm = tmask(ji,jj,jk) ! tmask - zn = 0.5_wp * zh * r1_rho0 * ztm - ! ! Potential Energy - ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn - ! ! alphaPE - pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn - pab_pe(ji,jj,jk,jp_sal) = rn_b0 * rn_mu2 * zn - ! - END_3D - ! - CASE( np_leos ) !== linear ISOMIP EOS ==! - ! - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - zt = pts(ji,jj,jk,jp_tem) - (-1._wp) ! temperature anomaly (t-T0) - zs = pts (ji,jj,jk,jp_sal) - 34.2_wp ! abs. salinity anomaly (s-S0) - zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point - ztm = tmask(ji,jj,jk) ! tmask - zn = 0.5_wp * zh * r1_rho0 * ztm - ! ! Potential Energy - ppen(ji,jj,jk) = 0. - ! ! alphaPE - pab_pe(ji,jj,jk,jp_tem) = 0. - pab_pe(ji,jj,jk,jp_sal) = 0. - ! - END_3D - ! - CASE DEFAULT - WRITE(ctmp1,*) ' bad flag value for neos = ', neos - CALL ctl_stop( 'eos_pen:', ctmp1 ) - ! - END SELECT - ! - IF( ln_timing ) CALL timing_stop('eos_pen') - ! - END SUBROUTINE eos_pen - - - SUBROUTINE eos_init - !!---------------------------------------------------------------------- - !! *** ROUTINE eos_init *** - !! - !! ** Purpose : initializations for the equation of state - !! - !! ** Method : Read the namelist nameos and control the parameters - !!---------------------------------------------------------------------- - INTEGER :: ios ! local integer - INTEGER :: ioptio ! local integer - !! - NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, ln_LEOS, rn_a0, rn_b0, & - & rn_lambda1, rn_mu1, rn_lambda2, rn_mu2, rn_nu - !!---------------------------------------------------------------------- - ! - READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist' ) - ! - READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) -902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist' ) - IF(lwm) WRITE( numond, nameos ) - ! - rho0 = 1027.51_wp !: volumic mass of reference [kg/m3] - rcp = 3974.00_wp !: heat capacity [J/K] - ! - IF(lwp) THEN ! Control print - WRITE(numout,*) - WRITE(numout,*) 'eos_init : equation of state' - WRITE(numout,*) '~~~~~~~~' - WRITE(numout,*) ' Namelist nameos : Chosen the Equation Of Seawater (EOS)' - WRITE(numout,*) ' TEOS-10 : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_TEOS10 = ', ln_TEOS10 - WRITE(numout,*) ' EOS-80 : rho=F(Potential Temperature, Practical Salinity, depth) ln_EOS80 = ', ln_EOS80 - WRITE(numout,*) ' S-EOS : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_SEOS = ', ln_SEOS - WRITE(numout,*) ' L-EOS : rho=F(Potential Temperature, Practical Salinity, depth) ln_LEOS = ', ln_LEOS - ENDIF - - ! Check options for equation of state & set neos based on logical flags - ioptio = 0 - IF( ln_TEOS10 ) THEN ; ioptio = ioptio+1 ; neos = np_teos10 ; ENDIF - IF( ln_EOS80 ) THEN ; ioptio = ioptio+1 ; neos = np_eos80 ; ENDIF - IF( ln_SEOS ) THEN ; ioptio = ioptio+1 ; neos = np_seos ; ENDIF - IF( ln_LEOS ) THEN ; ioptio = ioptio+1 ; neos = np_leos ; ENDIF - IF( ioptio /= 1 ) CALL ctl_stop("Exactly one equation of state option must be selected") - ! - SELECT CASE( neos ) ! check option - ! - CASE( np_teos10 ) !== polynomial TEOS-10 ==! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' ==>>> use of TEOS-10 equation of state (cons. temp. and abs. salinity)' - ! - l_useCT = .TRUE. ! model temperature is Conservative temperature - ! - rdeltaS = 32._wp - r1_S0 = 0.875_wp/35.16504_wp - r1_T0 = 1._wp/40._wp - r1_Z0 = 1.e-4_wp - ! - EOS000 = 8.0189615746e+02_wp - EOS100 = 8.6672408165e+02_wp - EOS200 = -1.7864682637e+03_wp - EOS300 = 2.0375295546e+03_wp - EOS400 = -1.2849161071e+03_wp - EOS500 = 4.3227585684e+02_wp - EOS600 = -6.0579916612e+01_wp - EOS010 = 2.6010145068e+01_wp - EOS110 = -6.5281885265e+01_wp - EOS210 = 8.1770425108e+01_wp - EOS310 = -5.6888046321e+01_wp - EOS410 = 1.7681814114e+01_wp - EOS510 = -1.9193502195_wp - EOS020 = -3.7074170417e+01_wp - EOS120 = 6.1548258127e+01_wp - EOS220 = -6.0362551501e+01_wp - EOS320 = 2.9130021253e+01_wp - EOS420 = -5.4723692739_wp - EOS030 = 2.1661789529e+01_wp - EOS130 = -3.3449108469e+01_wp - EOS230 = 1.9717078466e+01_wp - EOS330 = -3.1742946532_wp - EOS040 = -8.3627885467_wp - EOS140 = 1.1311538584e+01_wp - EOS240 = -5.3563304045_wp - EOS050 = 5.4048723791e-01_wp - EOS150 = 4.8169980163e-01_wp - EOS060 = -1.9083568888e-01_wp - EOS001 = 1.9681925209e+01_wp - EOS101 = -4.2549998214e+01_wp - EOS201 = 5.0774768218e+01_wp - EOS301 = -3.0938076334e+01_wp - EOS401 = 6.6051753097_wp - EOS011 = -1.3336301113e+01_wp - EOS111 = -4.4870114575_wp - EOS211 = 5.0042598061_wp - EOS311 = -6.5399043664e-01_wp - EOS021 = 6.7080479603_wp - EOS121 = 3.5063081279_wp - EOS221 = -1.8795372996_wp - EOS031 = -2.4649669534_wp - EOS131 = -5.5077101279e-01_wp - EOS041 = 5.5927935970e-01_wp - EOS002 = 2.0660924175_wp - EOS102 = -4.9527603989_wp - EOS202 = 2.5019633244_wp - EOS012 = 2.0564311499_wp - EOS112 = -2.1311365518e-01_wp - EOS022 = -1.2419983026_wp - EOS003 = -2.3342758797e-02_wp - EOS103 = -1.8507636718e-02_wp - EOS013 = 3.7969820455e-01_wp - ! - ALP000 = -6.5025362670e-01_wp - ALP100 = 1.6320471316_wp - ALP200 = -2.0442606277_wp - ALP300 = 1.4222011580_wp - ALP400 = -4.4204535284e-01_wp - ALP500 = 4.7983755487e-02_wp - ALP010 = 1.8537085209_wp - ALP110 = -3.0774129064_wp - ALP210 = 3.0181275751_wp - ALP310 = -1.4565010626_wp - ALP410 = 2.7361846370e-01_wp - ALP020 = -1.6246342147_wp - ALP120 = 2.5086831352_wp - ALP220 = -1.4787808849_wp - ALP320 = 2.3807209899e-01_wp - ALP030 = 8.3627885467e-01_wp - ALP130 = -1.1311538584_wp - ALP230 = 5.3563304045e-01_wp - ALP040 = -6.7560904739e-02_wp - ALP140 = -6.0212475204e-02_wp - ALP050 = 2.8625353333e-02_wp - ALP001 = 3.3340752782e-01_wp - ALP101 = 1.1217528644e-01_wp - ALP201 = -1.2510649515e-01_wp - ALP301 = 1.6349760916e-02_wp - ALP011 = -3.3540239802e-01_wp - ALP111 = -1.7531540640e-01_wp - ALP211 = 9.3976864981e-02_wp - ALP021 = 1.8487252150e-01_wp - ALP121 = 4.1307825959e-02_wp - ALP031 = -5.5927935970e-02_wp - ALP002 = -5.1410778748e-02_wp - ALP102 = 5.3278413794e-03_wp - ALP012 = 6.2099915132e-02_wp - ALP003 = -9.4924551138e-03_wp - ! - BET000 = 1.0783203594e+01_wp - BET100 = -4.4452095908e+01_wp - BET200 = 7.6048755820e+01_wp - BET300 = -6.3944280668e+01_wp - BET400 = 2.6890441098e+01_wp - BET500 = -4.5221697773_wp - BET010 = -8.1219372432e-01_wp - BET110 = 2.0346663041_wp - BET210 = -2.1232895170_wp - BET310 = 8.7994140485e-01_wp - BET410 = -1.1939638360e-01_wp - BET020 = 7.6574242289e-01_wp - BET120 = -1.5019813020_wp - BET220 = 1.0872489522_wp - BET320 = -2.7233429080e-01_wp - BET030 = -4.1615152308e-01_wp - BET130 = 4.9061350869e-01_wp - BET230 = -1.1847737788e-01_wp - BET040 = 1.4073062708e-01_wp - BET140 = -1.3327978879e-01_wp - BET050 = 5.9929880134e-03_wp - BET001 = -5.2937873009e-01_wp - BET101 = 1.2634116779_wp - BET201 = -1.1547328025_wp - BET301 = 3.2870876279e-01_wp - BET011 = -5.5824407214e-02_wp - BET111 = 1.2451933313e-01_wp - BET211 = -2.4409539932e-02_wp - BET021 = 4.3623149752e-02_wp - BET121 = -4.6767901790e-02_wp - BET031 = -6.8523260060e-03_wp - BET002 = -6.1618945251e-02_wp - BET102 = 6.2255521644e-02_wp - BET012 = -2.6514181169e-03_wp - BET003 = -2.3025968587e-04_wp - ! - PEN000 = -9.8409626043_wp - PEN100 = 2.1274999107e+01_wp - PEN200 = -2.5387384109e+01_wp - PEN300 = 1.5469038167e+01_wp - PEN400 = -3.3025876549_wp - PEN010 = 6.6681505563_wp - PEN110 = 2.2435057288_wp - PEN210 = -2.5021299030_wp - PEN310 = 3.2699521832e-01_wp - PEN020 = -3.3540239802_wp - PEN120 = -1.7531540640_wp - PEN220 = 9.3976864981e-01_wp - PEN030 = 1.2324834767_wp - PEN130 = 2.7538550639e-01_wp - PEN040 = -2.7963967985e-01_wp - PEN001 = -1.3773949450_wp - PEN101 = 3.3018402659_wp - PEN201 = -1.6679755496_wp - PEN011 = -1.3709540999_wp - PEN111 = 1.4207577012e-01_wp - PEN021 = 8.2799886843e-01_wp - PEN002 = 1.7507069098e-02_wp - PEN102 = 1.3880727538e-02_wp - PEN012 = -2.8477365341e-01_wp - ! - APE000 = -1.6670376391e-01_wp - APE100 = -5.6087643219e-02_wp - APE200 = 6.2553247576e-02_wp - APE300 = -8.1748804580e-03_wp - APE010 = 1.6770119901e-01_wp - APE110 = 8.7657703198e-02_wp - APE210 = -4.6988432490e-02_wp - APE020 = -9.2436260751e-02_wp - APE120 = -2.0653912979e-02_wp - APE030 = 2.7963967985e-02_wp - APE001 = 3.4273852498e-02_wp - APE101 = -3.5518942529e-03_wp - APE011 = -4.1399943421e-02_wp - APE002 = 7.1193413354e-03_wp - ! - BPE000 = 2.6468936504e-01_wp - BPE100 = -6.3170583896e-01_wp - BPE200 = 5.7736640125e-01_wp - BPE300 = -1.6435438140e-01_wp - BPE010 = 2.7912203607e-02_wp - BPE110 = -6.2259666565e-02_wp - BPE210 = 1.2204769966e-02_wp - BPE020 = -2.1811574876e-02_wp - BPE120 = 2.3383950895e-02_wp - BPE030 = 3.4261630030e-03_wp - BPE001 = 4.1079296834e-02_wp - BPE101 = -4.1503681096e-02_wp - BPE011 = 1.7676120780e-03_wp - BPE002 = 1.7269476440e-04_wp - ! - CASE( np_eos80 ) !== polynomial EOS-80 formulation ==! - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' ==>>> use of EOS-80 equation of state (pot. temp. and pract. salinity)' - ! - l_useCT = .FALSE. ! model temperature is Potential temperature - rdeltaS = 20._wp - r1_S0 = 1._wp/40._wp - r1_T0 = 1._wp/40._wp - r1_Z0 = 1.e-4_wp - ! - EOS000 = 9.5356891948e+02_wp - EOS100 = 1.7136499189e+02_wp - EOS200 = -3.7501039454e+02_wp - EOS300 = 5.1856810420e+02_wp - EOS400 = -3.7264470465e+02_wp - EOS500 = 1.4302533998e+02_wp - EOS600 = -2.2856621162e+01_wp - EOS010 = 1.0087518651e+01_wp - EOS110 = -1.3647741861e+01_wp - EOS210 = 8.8478359933_wp - EOS310 = -7.2329388377_wp - EOS410 = 1.4774410611_wp - EOS510 = 2.0036720553e-01_wp - EOS020 = -2.5579830599e+01_wp - EOS120 = 2.4043512327e+01_wp - EOS220 = -1.6807503990e+01_wp - EOS320 = 8.3811577084_wp - EOS420 = -1.9771060192_wp - EOS030 = 1.6846451198e+01_wp - EOS130 = -2.1482926901e+01_wp - EOS230 = 1.0108954054e+01_wp - EOS330 = -6.2675951440e-01_wp - EOS040 = -8.0812310102_wp - EOS140 = 1.0102374985e+01_wp - EOS240 = -4.8340368631_wp - EOS050 = 1.2079167803_wp - EOS150 = 1.1515380987e-01_wp - EOS060 = -2.4520288837e-01_wp - EOS001 = 1.0748601068e+01_wp - EOS101 = -1.7817043500e+01_wp - EOS201 = 2.2181366768e+01_wp - EOS301 = -1.6750916338e+01_wp - EOS401 = 4.1202230403_wp - EOS011 = -1.5852644587e+01_wp - EOS111 = -7.6639383522e-01_wp - EOS211 = 4.1144627302_wp - EOS311 = -6.6955877448e-01_wp - EOS021 = 9.9994861860_wp - EOS121 = -1.9467067787e-01_wp - EOS221 = -1.2177554330_wp - EOS031 = -3.4866102017_wp - EOS131 = 2.2229155620e-01_wp - EOS041 = 5.9503008642e-01_wp - EOS002 = 1.0375676547_wp - EOS102 = -3.4249470629_wp - EOS202 = 2.0542026429_wp - EOS012 = 2.1836324814_wp - EOS112 = -3.4453674320e-01_wp - EOS022 = -1.2548163097_wp - EOS003 = 1.8729078427e-02_wp - EOS103 = -5.7238495240e-02_wp - EOS013 = 3.8306136687e-01_wp - ! - ALP000 = -2.5218796628e-01_wp - ALP100 = 3.4119354654e-01_wp - ALP200 = -2.2119589983e-01_wp - ALP300 = 1.8082347094e-01_wp - ALP400 = -3.6936026529e-02_wp - ALP500 = -5.0091801383e-03_wp - ALP010 = 1.2789915300_wp - ALP110 = -1.2021756164_wp - ALP210 = 8.4037519952e-01_wp - ALP310 = -4.1905788542e-01_wp - ALP410 = 9.8855300959e-02_wp - ALP020 = -1.2634838399_wp - ALP120 = 1.6112195176_wp - ALP220 = -7.5817155402e-01_wp - ALP320 = 4.7006963580e-02_wp - ALP030 = 8.0812310102e-01_wp - ALP130 = -1.0102374985_wp - ALP230 = 4.8340368631e-01_wp - ALP040 = -1.5098959754e-01_wp - ALP140 = -1.4394226233e-02_wp - ALP050 = 3.6780433255e-02_wp - ALP001 = 3.9631611467e-01_wp - ALP101 = 1.9159845880e-02_wp - ALP201 = -1.0286156825e-01_wp - ALP301 = 1.6738969362e-02_wp - ALP011 = -4.9997430930e-01_wp - ALP111 = 9.7335338937e-03_wp - ALP211 = 6.0887771651e-02_wp - ALP021 = 2.6149576513e-01_wp - ALP121 = -1.6671866715e-02_wp - ALP031 = -5.9503008642e-02_wp - ALP002 = -5.4590812035e-02_wp - ALP102 = 8.6134185799e-03_wp - ALP012 = 6.2740815484e-02_wp - ALP003 = -9.5765341718e-03_wp - ! - BET000 = 2.1420623987_wp - BET100 = -9.3752598635_wp - BET200 = 1.9446303907e+01_wp - BET300 = -1.8632235232e+01_wp - BET400 = 8.9390837485_wp - BET500 = -1.7142465871_wp - BET010 = -1.7059677327e-01_wp - BET110 = 2.2119589983e-01_wp - BET210 = -2.7123520642e-01_wp - BET310 = 7.3872053057e-02_wp - BET410 = 1.2522950346e-02_wp - BET020 = 3.0054390409e-01_wp - BET120 = -4.2018759976e-01_wp - BET220 = 3.1429341406e-01_wp - BET320 = -9.8855300959e-02_wp - BET030 = -2.6853658626e-01_wp - BET130 = 2.5272385134e-01_wp - BET230 = -2.3503481790e-02_wp - BET040 = 1.2627968731e-01_wp - BET140 = -1.2085092158e-01_wp - BET050 = 1.4394226233e-03_wp - BET001 = -2.2271304375e-01_wp - BET101 = 5.5453416919e-01_wp - BET201 = -6.2815936268e-01_wp - BET301 = 2.0601115202e-01_wp - BET011 = -9.5799229402e-03_wp - BET111 = 1.0286156825e-01_wp - BET211 = -2.5108454043e-02_wp - BET021 = -2.4333834734e-03_wp - BET121 = -3.0443885826e-02_wp - BET031 = 2.7786444526e-03_wp - BET002 = -4.2811838287e-02_wp - BET102 = 5.1355066072e-02_wp - BET012 = -4.3067092900e-03_wp - BET003 = -7.1548119050e-04_wp - ! - PEN000 = -5.3743005340_wp - PEN100 = 8.9085217499_wp - PEN200 = -1.1090683384e+01_wp - PEN300 = 8.3754581690_wp - PEN400 = -2.0601115202_wp - PEN010 = 7.9263222935_wp - PEN110 = 3.8319691761e-01_wp - PEN210 = -2.0572313651_wp - PEN310 = 3.3477938724e-01_wp - PEN020 = -4.9997430930_wp - PEN120 = 9.7335338937e-02_wp - PEN220 = 6.0887771651e-01_wp - PEN030 = 1.7433051009_wp - PEN130 = -1.1114577810e-01_wp - PEN040 = -2.9751504321e-01_wp - PEN001 = -6.9171176978e-01_wp - PEN101 = 2.2832980419_wp - PEN201 = -1.3694684286_wp - PEN011 = -1.4557549876_wp - PEN111 = 2.2969116213e-01_wp - PEN021 = 8.3654420645e-01_wp - PEN002 = -1.4046808820e-02_wp - PEN102 = 4.2928871430e-02_wp - PEN012 = -2.8729602515e-01_wp - ! - APE000 = -1.9815805734e-01_wp - APE100 = -9.5799229402e-03_wp - APE200 = 5.1430784127e-02_wp - APE300 = -8.3694846809e-03_wp - APE010 = 2.4998715465e-01_wp - APE110 = -4.8667669469e-03_wp - APE210 = -3.0443885826e-02_wp - APE020 = -1.3074788257e-01_wp - APE120 = 8.3359333577e-03_wp - APE030 = 2.9751504321e-02_wp - APE001 = 3.6393874690e-02_wp - APE101 = -5.7422790533e-03_wp - APE011 = -4.1827210323e-02_wp - APE002 = 7.1824006288e-03_wp - ! - BPE000 = 1.1135652187e-01_wp - BPE100 = -2.7726708459e-01_wp - BPE200 = 3.1407968134e-01_wp - BPE300 = -1.0300557601e-01_wp - BPE010 = 4.7899614701e-03_wp - BPE110 = -5.1430784127e-02_wp - BPE210 = 1.2554227021e-02_wp - BPE020 = 1.2166917367e-03_wp - BPE120 = 1.5221942913e-02_wp - BPE030 = -1.3893222263e-03_wp - BPE001 = 2.8541225524e-02_wp - BPE101 = -3.4236710714e-02_wp - BPE011 = 2.8711395266e-03_wp - BPE002 = 5.3661089288e-04_wp - ! - CASE( np_seos ) !== Simplified EOS ==! - - r1_S0 = 0.875_wp/35.16504_wp ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct) - - IF(lwp) THEN - WRITE(numout,*) - WRITE(numout,*) ' ==>>> use of simplified eos: ' - WRITE(numout,*) ' rhd(dT=T-10,dS=S-35,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT ' - WRITE(numout,*) ' + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rho0' - WRITE(numout,*) ' with the following coefficients :' - WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0 - WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0 - WRITE(numout,*) ' cabbeling coef. rn_lambda1 = ', rn_lambda1 - WRITE(numout,*) ' cabbeling coef. rn_lambda2 = ', rn_lambda2 - WRITE(numout,*) ' thermobar. coef. rn_mu1 = ', rn_mu1 - WRITE(numout,*) ' thermobar. coef. rn_mu2 = ', rn_mu2 - WRITE(numout,*) ' 2nd cabbel. coef. rn_nu = ', rn_nu - WRITE(numout,*) ' Caution: rn_beta0=0 incompatible with ddm parameterization ' - ENDIF - l_useCT = .TRUE. ! Use conservative temperature - ! - CASE( np_leos ) !== Linear ISOMIP EOS ==! - - r1_S0 = 0.875_wp/35.16504_wp ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct) - - IF(lwp) THEN - WRITE(numout,*) - WRITE(numout,*) ' use of linear ISOMIP eos: rhd(dT=T-(-1),dS=S-(34.2),Z) = ' - WRITE(numout,*) ' [ -a0*dT + b0*dS ]/rho0' - WRITE(numout,*) - WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0 - WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0 - ENDIF - l_useCT = .TRUE. ! Use conservative temperature - ! - CASE DEFAULT !== ERROR in neos ==! - WRITE(ctmp1,*) ' bad flag value for neos = ', neos, '. You should never see this error' - CALL ctl_stop( ctmp1 ) - ! - END SELECT - ! - rho0_rcp = rho0 * rcp - r1_rho0 = 1._wp / rho0 - r1_rcp = 1._wp / rcp - r1_rho0_rcp = 1._wp / rho0_rcp - ! - IF(lwp) THEN - IF( l_useCT ) THEN - WRITE(numout,*) - WRITE(numout,*) ' ==>>> model uses Conservative Temperature' - WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' - ELSE - WRITE(numout,*) - WRITE(numout,*) ' ==>>> model does not use Conservative Temperature' - ENDIF - ENDIF - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' Associated physical constant' - IF(lwp) WRITE(numout,*) ' volumic mass of reference rho0 = ', rho0 , ' kg/m^3' - IF(lwp) WRITE(numout,*) ' 1. / rho0 r1_rho0 = ', r1_rho0, ' m^3/kg' - IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin' - IF(lwp) WRITE(numout,*) ' rho0 * rcp rho0_rcp = ', rho0_rcp - IF(lwp) WRITE(numout,*) ' 1. / ( rho0 * rcp ) r1_rho0_rcp = ', r1_rho0_rcp - ! - END SUBROUTINE eos_init - - !!====================================================================== -END MODULE eosbn2 diff --git a/tests/ISOMIP+/MY_SRC/isf_oce.F90 b/tests/ISOMIP+/MY_SRC/isf_oce.F90 index 3bf1b30da0cbf5af17e40e4d0de4d006dd4193d2..01aab242c9c1306e5e4bff649c9def654ddd9792 100644 --- a/tests/ISOMIP+/MY_SRC/isf_oce.F90 +++ b/tests/ISOMIP+/MY_SRC/isf_oce.F90 @@ -65,7 +65,7 @@ MODULE isf_oce ! REAL(wp), PARAMETER, PUBLIC :: rLfusisf = 0.334e6_wp !: latent heat of fusion of ice shelf [J/kg] REAL(wp), PARAMETER, PUBLIC :: rcpisf = 2000.0_wp !: specific heat of ice shelf [J/kg/K] - REAL(wp), PARAMETER, PUBLIC :: rkappa = 0.0_wp !: ISOMIP+ no heat diffusivity through the ice-shelf [m2/s] + REAL(wp), PARAMETER, PUBLIC :: rkappa = 0._wp !: ISOMIP: no heat diffusivity [m2/s] REAL(wp), PARAMETER, PUBLIC :: rhoisf = 920.0_wp !: volumic mass of ice shelf [kg/m3] REAL(wp), PARAMETER, PUBLIC :: rtsurf = -20.0 !: surface temperature [C] ! @@ -80,8 +80,8 @@ MODULE isf_oce ! ! 2.2 -------- ice shelf cavity melt namelist parameter ------------- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_cav !: - INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_cav , misfkb_cav !: - REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !: + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_cav , misfkb_cav !: shallowest and deepest level of the ice shelf + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !: thickness and fraction of deepest cell affected by the ice shelf REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_cav , fwfisf_cav_b !: before and now net fwf from the ice shelf [kg/m2/s] REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_cav_tsc , risf_cav_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s] TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfcav_fwf !: @@ -237,17 +237,28 @@ CONTAINS ! ierr = 0 ! set to zero if no array to be allocated ! - ALLOCATE( fwfisf_par (jpi,jpj) , fwfisf_par_b(jpi,jpj) , & - & fwfisf_cav (jpi,jpj) , fwfisf_cav_b(jpi,jpj) , & + ALLOCATE( fwfisf_par (jpi,jpj) , fwfisf_cav (jpi,jpj) , & & fwfisf_oasis(jpi,jpj) , STAT=ialloc ) ierr = ierr + ialloc ! - ALLOCATE( risf_par_tsc(jpi,jpj,jpts) , risf_par_tsc_b(jpi,jpj,jpts) , STAT=ialloc ) + ALLOCATE( risf_par_tsc(jpi,jpj,jpts) , STAT=ialloc ) ierr = ierr + ialloc ! - ALLOCATE( risf_cav_tsc(jpi,jpj,jpts) , risf_cav_tsc_b(jpi,jpj,jpts) , STAT=ialloc ) + ALLOCATE( risf_cav_tsc(jpi,jpj,jpts) , STAT=ialloc ) ierr = ierr + ialloc ! +#if ! defined key_RK3 + ! MLF : need to allocate before arrays + ALLOCATE( fwfisf_par_b(jpi,jpj) , fwfisf_cav_b(jpi,jpj) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( risf_par_tsc_b(jpi,jpj,jpts) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( risf_cav_tsc_b(jpi,jpj,jpts) , STAT=ialloc ) + ierr = ierr + ialloc +#endif + ! ALLOCATE( risfload(jpi,jpj) , STAT=ialloc ) ierr = ierr + ialloc ! @@ -260,10 +271,17 @@ CONTAINS ! initalisation of fwf and tsc array to 0 risfload (:,:) = 0._wp fwfisf_oasis(:,:) = 0._wp +#if defined key_RK3 + fwfisf_par (:,:) = 0._wp + fwfisf_cav (:,:) = 0._wp + risf_cav_tsc(:,:,:) = 0._wp + risf_par_tsc(:,:,:) = 0._wp +#else fwfisf_par (:,:) = 0._wp ; fwfisf_par_b (:,:) = 0._wp fwfisf_cav (:,:) = 0._wp ; fwfisf_cav_b (:,:) = 0._wp risf_cav_tsc(:,:,:) = 0._wp ; risf_cav_tsc_b(:,:,:) = 0._wp risf_par_tsc(:,:,:) = 0._wp ; risf_par_tsc_b(:,:,:) = 0._wp +#endif ! END SUBROUTINE isf_alloc diff --git a/tests/ISOMIP+/MY_SRC/isfcavgam.F90 b/tests/ISOMIP+/MY_SRC/isfcavgam.F90 deleted file mode 100644 index 6c0ac2a4d94db9b728d48603e65d1d2f31f548ef..0000000000000000000000000000000000000000 --- a/tests/ISOMIP+/MY_SRC/isfcavgam.F90 +++ /dev/null @@ -1,253 +0,0 @@ -MODULE isfcavgam - !!====================================================================== - !! *** MODULE isfgammats *** - !! Ice shelf gamma module : compute exchange coeficient at the ice/ocean interface - !!====================================================================== - !! History : 4.1 ! (P. Mathiot) original - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! isfcav_gammats : compute exchange coeficient gamma - !!---------------------------------------------------------------------- - USE isf_oce - USE isfutils, ONLY: debug - USE isftbl , ONLY: isf_tbl - - USE oce , ONLY: uu, vv ! ocean dynamics - USE phycst , ONLY: grav, vkarmn ! physical constant - USE eosbn2 , ONLY: eos_rab ! equation of state - USE zdfdrg , ONLY: rCd0_top, r_ke0_top ! vertical physics: top/bottom drag coef. - USE iom , ONLY: iom_put ! - USE lib_mpp , ONLY: ctl_stop - - USE dom_oce ! ocean space and time domain - USE in_out_manager ! I/O manager - ! - IMPLICIT NONE - ! - PRIVATE - ! - PUBLIC isfcav_gammats - - !! * Substitutions -# include "do_loop_substitute.h90" -# include "domzgr_substitute.h90" - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - ! - !!----------------------------------------------------------------------------------------------------- - !! PUBLIC SUBROUTINES - !!----------------------------------------------------------------------------------------------------- - ! - SUBROUTINE isfcav_gammats( Kmm, pttbl, pstbl, pqoce, pqfwf, pRc, pgt, pgs ) - !!---------------------------------------------------------------------- - !! ** Purpose : compute the coefficient echange for heat and fwf flux - !! - !! ** Method : select the gamma formulation - !! 3 method available (cst, vel and vel_stab) - !!--------------------------------------------------------------------- - !!-------------------------- OUT ------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt , pgs ! gamma t and gamma s - !!-------------------------- IN ------------------------------------- - INTEGER :: Kmm ! ocean time level index - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! isf heat and fwf - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number - !!--------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: zutbl, zvtbl ! top boundary layer velocity - !!--------------------------------------------------------------------- - ! - !========================================== - ! 1.: compute velocity in the tbl if needed - !========================================== - ! - SELECT CASE ( cn_gammablk ) - CASE ( 'spe' ) - ! gamma is constant (specified in namelist) - ! nothing to do - CASE ('vel', 'vel_stab') - ! compute velocity in tbl - CALL isf_tbl(Kmm, uu(:,:,:,Kmm) ,zutbl(:,:),'U', miku, rhisf_tbl_cav) - CALL isf_tbl(Kmm, vv(:,:,:,Kmm) ,zvtbl(:,:),'V', mikv, rhisf_tbl_cav) - ! - ! mask velocity in tbl with ice shelf mask - zutbl(:,:) = zutbl(:,:) * mskisf_cav(:,:) - zvtbl(:,:) = zvtbl(:,:) * mskisf_cav(:,:) - ! - ! output - CALL iom_put('utbl',zutbl(:,:)) - CALL iom_put('vtbl',zvtbl(:,:)) - CASE DEFAULT - CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)') - END SELECT - ! - !========================================== - ! 2.: compute gamma - !========================================== - ! - SELECT CASE ( cn_gammablk ) - CASE ( 'spe' ) ! gamma is constant (specified in namelist) - pgt(:,:) = rn_gammat0 - pgs(:,:) = rn_gammas0 - CASE ( 'vel' ) ! gamma is proportional to u* - CALL gammats_vel ( zutbl, zvtbl, rCd0_top, r_ke0_top, pgt, pgs ) - CASE ( 'vel_stab' ) ! gamma depends of stability of boundary layer and u* - CALL gammats_vel_stab (Kmm, pttbl, pstbl, zutbl, zvtbl, rCd0_top, r_ke0_top, pqoce, pqfwf, pRc, pgt, pgs ) - CASE DEFAULT - CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)') - END SELECT - ! - !========================================== - ! 3.: output and debug - !========================================== - ! - CALL iom_put('isfgammat', pgt(:,:)) - CALL iom_put('isfgammas', pgs(:,:)) - ! - IF (ln_isfdebug) THEN - CALL debug( 'isfcav_gam pgt:', pgt(:,:) ) - CALL debug( 'isfcav_gam pgs:', pgs(:,:) ) - END IF - ! - END SUBROUTINE isfcav_gammats - ! - !!----------------------------------------------------------------------------------------------------- - !! PRIVATE SUBROUTINES - !!----------------------------------------------------------------------------------------------------- - ! - SUBROUTINE gammats_vel( putbl, pvtbl, pCd, pke2, & ! <<== in - & pgt, pgs ) ! ==>> out gammats [m/s] - !!---------------------------------------------------------------------- - !! ** Purpose : compute the coefficient echange coefficient - !! - !! ** Method : gamma is velocity dependent ( gt= gt0 * Ustar ) - !! - !! ** Reference : Asay-Davis et al., Geosci. Model Dev., 9, 2471-2497, 2016 - !!--------------------------------------------------------------------- - !!-------------------------- OUT ------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas [m/s] - !!-------------------------- IN ------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coefficient - REAL(wp), INTENT(in ) :: pke2 ! background velocity - !!--------------------------------------------------------------------- - INTEGER :: ji, jj ! loop index - REAL(wp), DIMENSION(jpi,jpj) :: zustar - !!--------------------------------------------------------------------- - ! - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! compute ustar (AD15 eq. 27) - zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) ) * mskisf_cav(ji,jj) - ! - ! Compute gammats - pgt(ji,jj) = zustar(ji,jj) * rn_gammat0 - pgs(ji,jj) = zustar(ji,jj) * rn_gammas0 - END_2D - ! - ! output ustar - CALL iom_put('isfustar',zustar(:,:)) - ! - END SUBROUTINE gammats_vel - - SUBROUTINE gammats_vel_stab( Kmm, pttbl, pstbl, putbl, pvtbl, pCd, pke2, pqoce, pqfwf, pRc, & ! <<== in - & pgt , pgs ) ! ==>> out gammats [m/s] - !!---------------------------------------------------------------------- - !! ** Purpose : compute the coefficient echange coefficient - !! - !! ** Method : gamma is velocity dependent and stability dependent - !! - !! ** Reference : Holland and Jenkins, 1999, JPO, p1787-1800 - !!--------------------------------------------------------------------- - !!-------------------------- OUT ------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas - !!-------------------------- IN ------------------------------------- - INTEGER :: Kmm ! ocean time level index - REAL(wp), INTENT(in ) :: pke2 ! background velocity squared - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! surface heat flux and fwf flux - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coeficient - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! tracer in the losch top boundary layer - REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number - !!--------------------------------------------------------------------- - INTEGER :: ji, jj ! loop index - INTEGER :: ikt ! local integer - REAL(wp) :: zdku, zdkv ! U, V shear - REAL(wp) :: zPr, zSc ! Prandtl and Scmidth number - REAL(wp) :: zmob, zmols ! Monin Obukov length, coriolis factor at T point - REAL(wp) :: zbuofdep, zhnu ! Bouyancy length scale, sublayer tickness - REAL(wp) :: zhmax ! limitation of mol - REAL(wp) :: zetastar ! stability parameter - REAL(wp) :: zgmolet, zgmoles, zgturb ! contribution of modelecular sublayer and turbulence - REAL(wp) :: zcoef ! temporary coef - REAL(wp) :: zdep - REAL(wp) :: zeps = 1.0e-20_wp - REAL(wp), PARAMETER :: zxsiN = 0.052_wp ! dimensionless constant - REAL(wp), PARAMETER :: znu = 1.95e-6_wp ! kinamatic viscosity of sea water (m2.s-1) - REAL(wp), DIMENSION(2) :: zts, zab - REAL(wp), DIMENSION(jpi,jpj) :: zustar ! friction velocity - !!--------------------------------------------------------------------- - ! - ! compute Pr and Sc number (eq ??) - zPr = 13.8_wp - zSc = 2432.0_wp - ! - ! compute gamma mole (eq ??) - zgmolet = 12.5_wp * zPr ** (2.0/3.0) - 6.0_wp - zgmoles = 12.5_wp * zSc ** (2.0/3.0) - 6.0_wp - ! - ! compute gamma - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - - ikt = mikt(ji,jj) - - ! compute ustar - zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) ) - - IF( zustar(ji,jj) == 0._wp ) THEN ! only for kt = 1 I think - pgt(ji,jj) = rn_gammat0 - pgs(ji,jj) = rn_gammas0 - ELSE - ! compute bouyancy - zts(jp_tem) = pttbl(ji,jj) - zts(jp_sal) = pstbl(ji,jj) - zdep = gdepw(ji,jj,ikt,Kmm) - ! - CALL eos_rab( zts, zdep, zab, Kmm ) - ! - ! compute length scale (Eq ??) - zbuofdep = grav * ( zab(jp_tem) * pqoce(ji,jj) - zab(jp_sal) * pqfwf(ji,jj) ) - ! - ! compute Monin Obukov Length - ! Maximum boundary layer depth (Eq ??) - zhmax = gdept(ji,jj,mbkt(ji,jj),Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm) -0.001_wp - ! - ! Compute Monin obukhov length scale at the surface and Ekman depth: (Eq ??) - zmob = zustar(ji,jj) ** 3 / (vkarmn * (zbuofdep + zeps)) - zmols = SIGN(1._wp, zmob) * MIN(ABS(zmob), zhmax) * tmask(ji,jj,ikt) - ! - ! compute eta* (stability parameter) (Eq ??) - zetastar = 1._wp / ( SQRT(1._wp + MAX( 0._wp, zxsiN * zustar(ji,jj) & - & / MAX( 1.e-20, ABS(ff_t(ji,jj)) * zmols * pRc(ji,jj) ) ))) - ! - ! compute the sublayer thickness (Eq ??) - zhnu = 5 * znu / MAX( 1.e-20, zustar(ji,jj) ) - ! - ! compute gamma turb (Eq ??) - zgturb = 1._wp / vkarmn * LOG(zustar(ji,jj) * zxsiN * zetastar * zetastar / MAX( 1.e-10, ABS(ff_t(ji,jj)) * zhnu )) & - & + 1._wp / ( 2 * zxsiN * zetastar ) - 1._wp / vkarmn - ! - ! compute gammats - pgt(ji,jj) = zustar(ji,jj) / (zgturb + zgmolet) - pgs(ji,jj) = zustar(ji,jj) / (zgturb + zgmoles) - END IF - END_2D - ! output ustar - CALL iom_put('isfustar',zustar(:,:)) - - END SUBROUTINE gammats_vel_stab - -END MODULE isfcavgam diff --git a/tests/ISOMIP+/MY_SRC/isfstp.F90 b/tests/ISOMIP+/MY_SRC/isfstp.F90 deleted file mode 100644 index 2ab920844a3af8cf4afda88d68297208ce312358..0000000000000000000000000000000000000000 --- a/tests/ISOMIP+/MY_SRC/isfstp.F90 +++ /dev/null @@ -1,322 +0,0 @@ -MODULE isfstp - !!====================================================================== - !! *** MODULE isfstp *** - !! Ice Shelves : compute iceshelf load, melt and heat flux - !!====================================================================== - !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav - !! X.X ! 2006-02 (C. Wang ) Original code bg03 - !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization - !! 4.1 ! 2019-09 (P. Mathiot) Split param/explicit ice shelf and re-organisation - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! isfstp : compute iceshelf melt and heat flux - !!---------------------------------------------------------------------- - USE isf_oce ! isf variables - USE isfload, ONLY: isf_load ! ice shelf load - USE isftbl , ONLY: isf_tbl_lvl ! ice shelf boundary layer - USE isfpar , ONLY: isf_par, isf_par_init ! ice shelf parametrisation - USE isfcav , ONLY: isf_cav, isf_cav_init ! ice shelf cavity - USE isfcpl , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables - - USE dom_oce ! ocean space and time domain - USE oce , ONLY: ssh ! sea surface height - USE domvvl, ONLY: ln_vvl_zstar ! zstar logical - USE zdfdrg, ONLY: r_Cdmin_top, r_ke0_top ! vertical physics: top/bottom drag coef. - ! - USE lib_mpp, ONLY: ctl_stop, ctl_nam - USE fldread, ONLY: FLD, FLD_N - USE in_out_manager ! I/O manager - USE timing - - IMPLICIT NONE - PRIVATE - - PUBLIC isf_stp, isf_init, isf_nam ! routine called in sbcmod and divhor - - !! * Substitutions -# include "domzgr_substitute.h90" - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: isfstp.F90 15574 2021-12-03 19:32:50Z techene $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE isf_stp( kt, Kmm ) - !!--------------------------------------------------------------------- - !! *** ROUTINE isf_stp *** - !! - !! ** Purpose : compute total heat flux and total fwf due to ice shelf melt - !! - !! ** Method : For each case (parametrisation or explicity cavity) : - !! - define the before fields - !! - compute top boundary layer properties - !! (in case of parametrisation, this is the - !! depth range model array used to compute mean far fields properties) - !! - compute fluxes - !! - write restart variables - !!---------------------------------------------------------------------- - INTEGER, INTENT(in) :: kt ! ocean time step - INTEGER, INTENT(in) :: Kmm ! ocean time level index - ! - INTEGER :: jk ! loop index -#if defined key_qco - REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t ! 3D workspace -#endif - !!--------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('isf') - ! - !======================================================================= - ! 1.: compute melt and associated heat fluxes in the ice shelf cavities - !======================================================================= - ! - IF ( ln_isfcav_mlt ) THEN - ! - ! 1.1: before time step - IF ( kt /= nit000 ) THEN - risf_cav_tsc_b (:,:,:) = risf_cav_tsc (:,:,:) - fwfisf_cav_b(:,:) = fwfisf_cav(:,:) - END IF - ! - ! 1.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl) - rhisf_tbl_cav(:,:) = rn_htbl * mskisf_cav(:,:) -#if defined key_qco - DO jk = 1, jpk - ze3t(:,:,jk) = e3t(:,:,jk,Kmm) - END DO - CALL isf_tbl_lvl( ht(:,:), ze3t , misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) -#else - CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) -#endif - ! - ! 1.3: compute ice shelf melt - CALL isf_cav( kt, Kmm, risf_cav_tsc, fwfisf_cav ) - ! - END IF - ! - !================================================================================= - ! 2.: compute melt and associated heat fluxes for not resolved ice shelf cavities - !================================================================================= - ! - IF ( ln_isfpar_mlt ) THEN - ! - ! 2.1: before time step - IF ( kt /= nit000 ) THEN - risf_par_tsc_b(:,:,:) = risf_par_tsc(:,:,:) - fwfisf_par_b (:,:) = fwfisf_par (:,:) - END IF - ! - ! 2.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl) - ! by simplicity, we assume the top level where param applied do not change with time (done in init part) - rhisf_tbl_par(:,:) = rhisf0_tbl_par(:,:) -#if defined key_qco - DO jk = 1, jpk - ze3t(:,:,jk) = e3t(:,:,jk,Kmm) - END DO - CALL isf_tbl_lvl( ht(:,:), ze3t , misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) -#else - CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) -#endif - ! - ! 2.3: compute ice shelf melt - CALL isf_par( kt, Kmm, risf_par_tsc, fwfisf_par ) - ! - END IF - ! - !================================================================================== - ! 3.: output specific restart variable in case of coupling with an ice sheet model - !================================================================================== - ! - IF ( ln_isfcpl .AND. lrst_oce ) CALL isfcpl_rst_write(kt, Kmm) - ! - IF( ln_timing ) CALL timing_stop('isf') - ! - END SUBROUTINE isf_stp - - - SUBROUTINE isf_init( Kbb, Kmm, Kaa ) - !!--------------------------------------------------------------------- - !! *** ROUTINE isfstp_init *** - !! - !! ** Purpose : Initialisation of the ice shelf public variables - !! - !! ** Method : Read the namisf namelist, check option compatibility and set derived parameters - !! - !! ** Action : - read namisf parameters - !! - allocate memory - !! - output print - !! - ckeck option compatibility - !! - call cav/param/isfcpl init routine - !!---------------------------------------------------------------------- - INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices - !!---------------------------------------------------------------------- - ! - ! constrain: l_isfoasis need to be known - ! - CALL isf_nam() ! Read namelist - ! - CALL isf_alloc() ! Allocate public array - ! - CALL isf_ctl() ! check option compatibility - ! - IF( ln_isfcav ) CALL isf_load( Kmm, risfload ) ! compute ice shelf load - ! - ! terminate routine now if no ice shelf melt formulation specify - IF( ln_isf ) THEN - ! - IF( ln_isfcav_mlt ) CALL isf_cav_init() ! initialisation melt in the cavity - ! - IF( ln_isfpar_mlt ) CALL isf_par_init() ! initialisation parametrised melt - ! - IF( ln_isfcpl ) CALL isfcpl_init( Kbb, Kmm, Kaa ) ! initialisation ice sheet coupling - ! - END IF - - END SUBROUTINE isf_init - - - SUBROUTINE isf_ctl() - !!--------------------------------------------------------------------- - !! *** ROUTINE isf_ctl *** - !! - !! ** Purpose : output print and option compatibility check - !! - !!---------------------------------------------------------------------- - IF (lwp) THEN - WRITE(numout,*) - WRITE(numout,*) 'isf_init : ice shelf initialisation' - WRITE(numout,*) '~~~~~~~~~~~~' - WRITE(numout,*) ' Namelist namisf :' - ! - WRITE(numout,*) ' ice shelf cavity (open or parametrised) ln_isf = ', ln_isf - WRITE(numout,*) - ! - IF ( ln_isf ) THEN -#if key_qco -# if ! defined key_isf - CALL ctl_stop( 'STOP', 'isf_ctl: ice shelf requires both ln_isf=T AND key_isf activated' ) -# endif -#endif - WRITE(numout,*) ' Add debug print in isf module ln_isfdebug = ', ln_isfdebug - WRITE(numout,*) - WRITE(numout,*) ' melt inside the cavity ln_isfcav_mlt = ', ln_isfcav_mlt - IF ( ln_isfcav_mlt) THEN - WRITE(numout,*) ' melt formulation cn_isfcav_mlt= ', TRIM(cn_isfcav_mlt) - WRITE(numout,*) ' thickness of the top boundary layer rn_htbl = ', rn_htbl - WRITE(numout,*) ' gamma formulation cn_gammablk = ', TRIM(cn_gammablk) - IF ( TRIM(cn_gammablk) .NE. 'spe' ) THEN - WRITE(numout,*) ' gammat coefficient rn_gammat0 = ', rn_gammat0 - WRITE(numout,*) ' gammas coefficient rn_gammas0 = ', rn_gammas0 - WRITE(numout,*) ' top background ke used (from namdrg_top) rn_ke0 = ', r_ke0_top - WRITE(numout,*) ' top drag coef. used (from namdrg_top) rn_Cd0 = ', r_Cdmin_top - END IF - END IF - WRITE(numout,*) '' - ! - WRITE(numout,*) ' ice shelf melt parametrisation ln_isfpar_mlt = ', ln_isfpar_mlt - IF ( ln_isfpar_mlt ) THEN - WRITE(numout,*) ' isf parametrisation formulation cn_isfpar_mlt = ', TRIM(cn_isfpar_mlt) - END IF - WRITE(numout,*) '' - ! - WRITE(numout,*) ' Coupling to an ice sheet model ln_isfcpl = ', ln_isfcpl - IF ( ln_isfcpl ) THEN - WRITE(numout,*) ' conservation activated ln_isfcpl_cons = ', ln_isfcpl_cons - WRITE(numout,*) ' number of call of the extrapolation loop = ', nn_drown - ENDIF - WRITE(numout,*) '' - ! - ELSE - ! - IF ( ln_isfcav ) THEN - WRITE(numout,*) '' - WRITE(numout,*) ' W A R N I N G: ice shelf cavities are open BUT no melt will be computed or read from file !' - WRITE(numout,*) '' - END IF - ! - END IF - - IF (ln_isfcav) THEN - WRITE(numout,*) ' Ice shelf load method cn_isfload = ', TRIM(cn_isfload) - WRITE(numout,*) ' Temperature used to compute the ice shelf load = ', rn_isfload_T - WRITE(numout,*) ' Salinity used to compute the ice shelf load = ', rn_isfload_S - END IF - WRITE(numout,*) '' - FLUSH(numout) - - END IF - ! - - !--------------------------------------------------------------------------------------------------------------------- - ! sanity check ! issue ln_isfcav not yet known as well as l_isfoasis => move this call in isf_stp ? - ! melt in the cavity without cavity - IF ( ln_isfcav_mlt .AND. (.NOT. ln_isfcav) ) & - & CALL ctl_stop('ice shelf melt in the cavity activated (ln_isfcav_mlt) but no cavity detected in domcfg (ln_isfcav), STOP' ) - ! - ! ice sheet coupling without cavity - IF ( ln_isfcpl .AND. (.NOT. ln_isfcav) ) & - & CALL ctl_stop('coupling with an ice sheet model detected (ln_isfcpl) but no cavity detected in domcfg (ln_isfcav), STOP' ) - ! - IF ( ln_isfcpl .AND. ln_isfcpl_cons .AND. ln_linssh ) & - & CALL ctl_stop( 'The coupling between NEMO and an ice sheet model with the conservation option does not work with the linssh option' ) - ! - IF ( l_isfoasis .AND. .NOT. ln_isf ) CALL ctl_stop( ' OASIS send ice shelf fluxes to NEMO but NEMO does not have the isf module activated' ) - ! - IF ( l_isfoasis .AND. ln_isf ) THEN - ! - CALL ctl_stop( 'namelist combination ln_cpl and ln_isf not tested' ) - ! - ! NEMO coupled to ATMO model with isf cavity need oasis method for melt computation - IF ( ln_isfcav_mlt .AND. TRIM(cn_isfcav_mlt) /= 'oasis' ) CALL ctl_stop( 'cn_isfcav_mlt = oasis is the only option availble if fwf send by oasis' ) - IF ( ln_isfpar_mlt .AND. TRIM(cn_isfpar_mlt) /= 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis is the only option availble if fwf send by oasis' ) - ! - ! oasis melt computation not tested (coded but not tested) - IF ( ln_isfcav_mlt .OR. ln_isfpar_mlt ) THEN - IF ( TRIM(cn_isfcav_mlt) == 'oasis' ) CALL ctl_stop( 'cn_isfcav_mlt = oasis not tested' ) - IF ( TRIM(cn_isfpar_mlt) == 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis not tested' ) - END IF - ! - ! oasis melt computation with cavity open and cavity parametrised (not coded) - IF ( ln_isfcav_mlt .AND. ln_isfpar_mlt ) THEN - IF ( TRIM(cn_isfpar_mlt) == 'oasis' .AND. TRIM(cn_isfcav_mlt) == 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis and cn_isfcav_mlt = oasis not coded' ) - END IF - ! - ! compatibility ice shelf and vvl - IF( .NOT. ln_vvl_zstar .AND. ln_isf ) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' ) - ! - END IF - END SUBROUTINE isf_ctl - - - SUBROUTINE isf_nam - !!--------------------------------------------------------------------- - !! *** ROUTINE isf_nam *** - !! - !! ** Purpose : Read ice shelf namelist cfg and ref - !! - !!---------------------------------------------------------------------- - INTEGER :: ios ! Local integer output status for namelist read - !!---------------------------------------------------------------------- - NAMELIST/namisf/ ln_isf , & - & cn_gammablk , rn_gammat0 , rn_gammas0 , rn_htbl, sn_isfcav_fwf, & - & ln_isfcav_mlt , cn_isfcav_mlt , sn_isfcav_fwf , & - & ln_isfpar_mlt , cn_isfpar_mlt , sn_isfpar_fwf , & - & sn_isfpar_zmin, sn_isfpar_zmax, sn_isfpar_Leff, & - & ln_isfcpl , nn_drown , ln_isfcpl_cons, ln_isfdebug, & - & cn_isfload , rn_isfload_T , rn_isfload_S , cn_isfdir , & - & rn_isfpar_bg03_gt0 - !!---------------------------------------------------------------------- - ! - READ ( numnam_ref, namisf, IOSTAT = ios, ERR = 901) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namisf in reference namelist' ) - ! - READ ( numnam_cfg, namisf, IOSTAT = ios, ERR = 902 ) -902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namisf in configuration namelist' ) - IF(lwm) WRITE ( numond, namisf ) - - END SUBROUTINE isf_nam - !! - !!====================================================================== -END MODULE isfstp diff --git a/tests/ISOMIP+/MY_SRC/istate.F90 b/tests/ISOMIP+/MY_SRC/istate.F90 index 0f32b25a96257355ffeb7d9dd22781306a3a860a..f8cdc262762b1924cd952399e213ad6faabb5a5a 100644 --- a/tests/ISOMIP+/MY_SRC/istate.F90 +++ b/tests/ISOMIP+/MY_SRC/istate.F90 @@ -50,7 +50,7 @@ MODULE istate # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: istate.F90 15581 2021-12-07 13:08:22Z techene $ + !! $Id: istate.F90 14991 2021-06-14 19:52:31Z techene $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -79,10 +79,12 @@ CONTAINS CALL dta_tsd_init ! Initialisation of T & S input data IF( ln_c1d) CALL dta_uvd_init ! Initialisation of U & V input data (c1d only) - rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk - rn2b (:,:,: ) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk - ts (:,:,:,:,Kaa) = 0._wp ! set one for all to 0 at level jpk - rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk + ts (:,:,:,:,Kaa) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk + IF ( ALLOCATED( rhd ) ) THEN ! SWE, for example, will not have allocated these + rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk + rn2b (:,:,: ) = 0._wp ! set one for all to 0 at level jpk + rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk + ENDIF #if defined key_agrif uu (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization vv (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization @@ -113,7 +115,7 @@ CONTAINS ! ! Initialization of ocean to zero ! IF( ln_tsd_init ) THEN - CALL dta_tsd( nit000, 'ini', ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 + CALL dta_tsd( nit000, ts(:,:,:,:,Kbb), 'ini' ) ! read 3D T and S data at nit000 ENDIF ! IF( ln_uvd_init .AND. ln_c1d ) THEN @@ -141,20 +143,6 @@ CONTAINS ENDIF #endif ! - ! Initialize "now" barotropic velocities: - ! Do it whatever the free surface method, these arrays being used eventually - ! -!!gm the use of umask & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked -#if ! defined key_RK3 - uu_b(:,:,Kmm) = 0._wp ; vv_b(:,:,Kmm) = 0._wp - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) - uu_b(ji,jj,Kmm) = uu_b(ji,jj,Kmm) + e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) * umask(ji,jj,jk) - vv_b(ji,jj,Kmm) = vv_b(ji,jj,Kmm) + e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) * vmask(ji,jj,jk) - END_3D - uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm) - vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm) -#endif - ! #if defined key_RK3 IF( .NOT. ln_rstart ) THEN #endif @@ -171,6 +159,25 @@ CONTAINS ! #if defined key_RK3 ENDIF +#endif + ! + ! Initialize "now" barotropic velocities: + ! Do it whatever the free surface method, these arrays being used eventually + ! +#if defined key_RK3 + IF( .NOT. ln_rstart ) THEN + uu_b(:,:,Kmm) = uu_b(:,:,Kbb) ! Kmm value set to Kbb for initialisation in Agrif_Regrid in namo_gcm + vv_b(:,:,Kmm) = vv_b(:,:,Kbb) + ENDIF +#else +!!gm the use of umask & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked + uu_b(:,:,Kmm) = 0._wp ; vv_b(:,:,Kmm) = 0._wp + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + uu_b(ji,jj,Kmm) = uu_b(ji,jj,Kmm) + e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) * umask(ji,jj,jk) + vv_b(ji,jj,Kmm) = vv_b(ji,jj,Kmm) + e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) * vmask(ji,jj,jk) + END_3D + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm) #endif ! END SUBROUTINE istate_init diff --git a/tests/ISOMIP+/MY_SRC/sbcfwb.F90 b/tests/ISOMIP+/MY_SRC/sbcfwb.F90 deleted file mode 100644 index 0102aa12740247e044537fa78f63c58149b73414..0000000000000000000000000000000000000000 --- a/tests/ISOMIP+/MY_SRC/sbcfwb.F90 +++ /dev/null @@ -1,277 +0,0 @@ -MODULE sbcfwb - !!====================================================================== - !! *** MODULE sbcfwb *** - !! Ocean fluxes : domain averaged freshwater budget - !!====================================================================== - !! History : OPA ! 2001-02 (E. Durand) Original code - !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module - !! 3.0 ! 2006-08 (G. Madec) Surface module - !! 3.2 ! 2009-07 (C. Talandier) emp mean s spread over erp area - !! 3.6 ! 2014-11 (P. Mathiot ) add ice shelf melting - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! sbc_fwb : freshwater budget for global ocean configurations (free surface & forced mode) - !!---------------------------------------------------------------------- - USE oce ! ocean dynamics and tracers - USE dom_oce ! ocean space and time domain - USE sbc_oce ! surface ocean boundary condition - USE isf_oce , ONLY : fwfisf_cav, fwfisf_par, ln_isfcpl, ln_isfcpl_cons, risfcpl_cons_ssh ! ice shelf melting contribution - USE sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass - USE phycst ! physical constants - USE sbcrnf ! ocean runoffs - USE sbcssr ! Sea-Surface damping terms - ! - USE in_out_manager ! I/O manager - USE iom ! IOM - USE lib_mpp ! distribued memory computing library - USE timing ! Timing - USE lbclnk ! ocean lateral boundary conditions - USE lib_fortran ! - - IMPLICIT NONE - PRIVATE - - PUBLIC sbc_fwb ! routine called by step - - REAL(wp) :: rn_fwb0 ! initial freshwater adjustment flux [kg/m2/s] (nn_fwb = 2 only) - REAL(wp) :: a_fwb ! annual domain averaged freshwater budget from the previous year - REAL(wp) :: a_fwb_b ! annual domain averaged freshwater budget from the year before or at initial state - REAL(wp) :: a_fwb_ini ! initial domain averaged freshwater budget - REAL(wp) :: area ! global mean ocean surface (interior domain) - - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: sbcfwb.F90 11395 2019-08-02 14:19:00Z mathiot $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE sbc_fwb( kt, kn_fwb, kn_fsbc, Kmm ) - !!--------------------------------------------------------------------- - !! *** ROUTINE sbc_fwb *** - !! - !! ** Purpose : Control the mean sea surface drift - !! - !! ** Method : several ways depending on kn_fwb - !! =0 no control - !! =1 global mean of emp set to zero at each nn_fsbc time step - !! =2 annual global mean corrected from previous year - !! =3 global mean of emp set to zero at each nn_fsbc time step - !! & spread out over erp area depending its sign - !! Note: if sea ice is embedded it is taken into account when computing the budget - !!---------------------------------------------------------------------- - INTEGER, INTENT( in ) :: kt ! ocean time-step index - INTEGER, INTENT( in ) :: kn_fsbc ! - INTEGER, INTENT( in ) :: kn_fwb ! ocean time-step index - INTEGER, INTENT( in ) :: Kmm ! ocean time level index - ! - INTEGER :: ios, inum, ikty ! local integers - REAL(wp) :: z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp ! local scalars - REAL(wp) :: zsurf_neg, zsurf_pos, zsurf_tospread, zcoef ! - - - REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_neg, ztmsk_pos, z_wgt ! 2D workspaces - REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_tospread, zerp_cor ! - - - REAL(wp) ,DIMENSION(1) :: z_fwfprv - COMPLEX(dp),DIMENSION(1) :: y_fwfnow - ! - NAMELIST/namsbc_fwb/rn_fwb0 - !!---------------------------------------------------------------------- - ! - IF( kt == nit000 ) THEN - READ( numnam_ref, namsbc_fwb, IOSTAT = ios, ERR = 901 ) -901 IF( ios /= 0 ) CALL ctl_nam( ios, 'namsbc_fwb in reference namelist' ) - READ( numnam_cfg, namsbc_fwb, IOSTAT = ios, ERR = 902 ) -902 IF( ios > 0 ) CALL ctl_nam( ios, 'namsbc_fwb in configuration namelist' ) - IF(lwm) WRITE( numond, namsbc_fwb ) - IF(lwp) THEN - WRITE(numout,*) - WRITE(numout,*) 'sbc_fwb : FreshWater Budget correction' - WRITE(numout,*) '~~~~~~~' - IF( kn_fwb == 1 ) WRITE(numout,*) ' instantaneously set to zero' - IF( kn_fwb == 4 ) WRITE(numout,*) ' instantaneously set to zero with heat and salt flux correction (ISOMIP+)' - IF( kn_fwb == 3 ) WRITE(numout,*) ' fwf set to zero and spread out over erp area' - IF( kn_fwb == 2 ) THEN - WRITE(numout,*) ' adjusted from previous year budget' - WRITE(numout,*) - WRITE(numout,*) ' Namelist namsbc_fwb' - WRITE(numout,*) ' Initial freshwater adjustment flux [kg/m2/s] = ', rn_fwb0 - END IF - ENDIF - ! - IF( kn_fwb == 3 .AND. nn_sssr /= 2 ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' ) - IF( kn_fwb == 3 .AND. ln_isfcav ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' ) - ! - area = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask(:,:,1)) ! interior global domain surface - ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes - ! and in case of no melt, it can generate HSSW. - ! -#if ! defined key_si3 && ! defined key_cice - snwice_mass_b(:,:) = 0.e0 ! no sea-ice model is being used : no snow+ice mass - snwice_mass (:,:) = 0.e0 - snwice_fmass (:,:) = 0.e0 -#endif - ! - ENDIF - - SELECT CASE ( kn_fwb ) - ! - CASE ( 1 ) !== global mean fwf set to zero ==! - ! - IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN - y_fwfnow(1) = local_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) - CALL mpp_delay_sum( 'sbcfwb', 'fwb', y_fwfnow(:), z_fwfprv(:), kt == nitend - nn_fsbc + 1 ) - z_fwfprv(1) = z_fwfprv(1) / area - zcoef = z_fwfprv(1) * rcp - emp(:,:) = emp(:,:) - z_fwfprv(1) * tmask(:,:,1) - qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction - ! outputs - IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', zcoef * sst_m(:,:) * tmask(:,:,1) ) - IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', z_fwfprv(1) * tmask(:,:,1) ) - ENDIF - ! - CASE ( 2 ) !== fw adjustment based on fw budget at the end of the previous year ==! - ! simulation is supposed to start 1st of January - IF( kt == nit000 ) THEN ! initialisation - ! ! set the fw adjustment (a_fwb) - IF ( ln_rstart .AND. iom_varid( numror, 'a_fwb_b', ldstop = .FALSE. ) > 0 & ! as read from restart file - & .AND. iom_varid( numror, 'a_fwb', ldstop = .FALSE. ) > 0 ) THEN - IF(lwp) WRITE(numout,*) 'sbc_fwb : reading freshwater-budget from restart file' - CALL iom_get( numror, 'a_fwb_b', a_fwb_b ) - CALL iom_get( numror, 'a_fwb' , a_fwb ) - ! - a_fwb_ini = a_fwb_b - ELSE ! as specified in namelist - IF(lwp) WRITE(numout,*) 'sbc_fwb : setting freshwater-budget from namelist rn_fwb0' - a_fwb = rn_fwb0 - a_fwb_b = 0._wp ! used only the first year then it is replaced by a_fwb_ini - ! - a_fwb_ini = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) & - & * rho0 / ( area * rday * REAL(nyear_len(1), wp) ) - END IF - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*)'sbc_fwb : freshwater-budget at the end of previous year = ', a_fwb , 'kg/m2/s' - IF(lwp) WRITE(numout,*)' freshwater-budget at initial state = ', a_fwb_ini, 'kg/m2/s' - ! - ELSE - ! at the end of year n: - ikty = nyear_len(1) * 86400 / NINT(rn_Dt) - IF( MOD( kt, ikty ) == 0 ) THEN ! Update a_fwb at the last time step of a year - ! It should be the first time step of a year MOD(kt-1,ikty) but then the restart would be wrong - ! Hence, we make a small error here but the code is restartable - a_fwb_b = a_fwb_ini - ! mean sea level taking into account ice+snow - a_fwb = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) - a_fwb = a_fwb * rho0 / ( area * rday * REAL(nyear_len(1), wp) ) ! convert in kg/m2/s - ENDIF - ! - ENDIF - ! - IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes using previous year budget minus initial state - zcoef = ( a_fwb - a_fwb_b ) - emp(:,:) = emp(:,:) + zcoef * tmask(:,:,1) - qns(:,:) = qns(:,:) - zcoef * rcp * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction - ! outputs - IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zcoef * rcp * sst_m(:,:) * tmask(:,:,1) ) - IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zcoef * tmask(:,:,1) ) - ENDIF - ! Output restart information - IF( lrst_oce ) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'sbc_fwb : writing FW-budget adjustment to ocean restart file at it = ', kt - IF(lwp) WRITE(numout,*) '~~~~' - CALL iom_rstput( kt, nitrst, numrow, 'a_fwb_b', a_fwb_b ) - CALL iom_rstput( kt, nitrst, numrow, 'a_fwb', a_fwb ) - END IF - ! - IF( kt == nitend .AND. lwp ) THEN - WRITE(numout,*) 'sbc_fwb : freshwater-budget at the end of simulation (year now) = ', a_fwb , 'kg/m2/s' - WRITE(numout,*) ' freshwater-budget at initial state = ', a_fwb_b, 'kg/m2/s' - ENDIF - ! - CASE ( 3 ) !== global fwf set to zero and spread out over erp area ==! - ! - ALLOCATE( ztmsk_neg(jpi,jpj) , ztmsk_pos(jpi,jpj) , ztmsk_tospread(jpi,jpj) , z_wgt(jpi,jpj) , zerp_cor(jpi,jpj) ) - ! - IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN - ztmsk_pos(:,:) = tmask_i(:,:) ! Select <0 and >0 area of erp - WHERE( erp < 0._wp ) ztmsk_pos = 0._wp - ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:) - ! ! fwf global mean (excluding ocean to ice/snow exchanges) - z_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) / area - ! - IF( z_fwf < 0._wp ) THEN ! spread out over >0 erp area to increase evaporation - zsurf_pos = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_pos(:,:) ) - zsurf_tospread = zsurf_pos - ztmsk_tospread(:,:) = ztmsk_pos(:,:) - ELSE ! spread out over <0 erp area to increase precipitation - zsurf_neg = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_neg(:,:) ) ! Area filled by <0 and >0 erp - zsurf_tospread = zsurf_neg - ztmsk_tospread(:,:) = ztmsk_neg(:,:) - ENDIF - ! - zsum_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * z_fwf ) ! fwf global mean over <0 or >0 erp area -!!gm : zsum_fwf = z_fwf * area ??? it is right? I think so.... - z_fwf_nsrf = zsum_fwf / ( zsurf_tospread + rsmall ) - ! ! weight to respect erp field 2D structure - zsum_erp = glob_sum( 'sbcfwb', ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) ) - z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall ) - ! ! final correction term to apply - zerp_cor(:,:) = -1. * z_fwf_nsrf * zsurf_tospread * z_wgt(:,:) - ! -!!gm ===>>>> lbc_lnk should be useless as all the computation is done over the whole domain ! - CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp ) - ! - emp(:,:) = emp(:,:) + zerp_cor(:,:) - qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:) ! account for change to the heat budget due to fw correction - erp(:,:) = erp(:,:) + zerp_cor(:,:) - ! outputs - IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zerp_cor(:,:) * rcp * sst_m(:,:) ) - IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zerp_cor(:,:) ) - ! - IF( lwp ) THEN ! control print - IF( z_fwf < 0._wp ) THEN - WRITE(numout,*)' z_fwf < 0' - WRITE(numout,*)' SUM(erp+) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' - ELSE - WRITE(numout,*)' z_fwf >= 0' - WRITE(numout,*)' SUM(erp-) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' - ENDIF - WRITE(numout,*)' SUM(empG) = ', SUM( z_fwf*e1e2t(:,:) )*1.e-9,' Sv' - WRITE(numout,*)' z_fwf = ', z_fwf ,' Kg/m2/s' - WRITE(numout,*)' z_fwf_nsrf = ', z_fwf_nsrf ,' Kg/m2/s' - WRITE(numout,*)' MIN(zerp_cor) = ', MINVAL(zerp_cor) - WRITE(numout,*)' MAX(zerp_cor) = ', MAXVAL(zerp_cor) - ENDIF - ENDIF - DEALLOCATE( ztmsk_neg , ztmsk_pos , ztmsk_tospread , z_wgt , zerp_cor ) - ! - CASE ( 4 ) !== global mean fwf set to zero (ISOMIP case) ==! - ! - IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN - z_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) - ! - ! correction for ice sheet coupling testing (ie remove the excess through the surface) - ! test impact on the melt as conservation correction made in depth - ! test conservation level as sbcfwb is conserving - ! avoid the model to blow up for large ssh drop (isomip OCEAN3 with melt switch off and uniform T/S) - IF (ln_isfcpl .AND. ln_isfcpl_cons) THEN - z_fwf = z_fwf + glob_sum( 'sbcfwb', e1e2t(:,:) * risfcpl_cons_ssh(:,:) * rho0 ) - END IF - ! - z_fwf = z_fwf / area - zcoef = z_fwf * rcp - emp(:,:) = emp(:,:) - z_fwf * tmask(:,:,1) ! (Eq. 34 AD2015) - qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! (Eq. 35 AD2015) ! use sst_m to avoid generation of any bouyancy fluxes - sfx(:,:) = sfx(:,:) + z_fwf * sss_m(:,:) * tmask(:,:,1) ! (Eq. 36 AD2015) ! use sss_m to avoid generation of any bouyancy fluxes - ENDIF - ! - CASE DEFAULT !== you should never be there ==! - CALL ctl_stop( 'sbc_fwb : wrong nn_fwb value for the FreshWater Budget correction, choose either 1, 2 or 3' ) - ! - END SELECT - ! - END SUBROUTINE sbc_fwb - - !!====================================================================== -END MODULE sbcfwb diff --git a/tests/ISOMIP+/MY_SRC/tradmp.F90 b/tests/ISOMIP+/MY_SRC/tradmp.F90 deleted file mode 100644 index 05ed5b09aa1bbdcabb8968ffc18dfd51e11f2acb..0000000000000000000000000000000000000000 --- a/tests/ISOMIP+/MY_SRC/tradmp.F90 +++ /dev/null @@ -1,243 +0,0 @@ -MODULE tradmp - !!====================================================================== - !! *** MODULE tradmp *** - !! Ocean physics: internal restoring trend on active tracers (T and S) - !!====================================================================== - !! History : OPA ! 1991-03 (O. Marti, G. Madec) Original code - !! ! 1992-06 (M. Imbard) doctor norme - !! ! 1998-07 (M. Imbard, G. Madec) ORCA version - !! 7.0 ! 2001-02 (M. Imbard) add distance to coast, Original code - !! 8.1 ! 2001-02 (G. Madec, E. Durand) cleaning - !! NEMO 1.0 ! 2002-08 (G. Madec, E. Durand) free form + modules - !! 3.2 ! 2009-08 (G. Madec, C. Talandier) DOCTOR norm for namelist parameter - !! 3.3 ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC - !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal + suppression of CPP keys - !! 3.6 ! 2015-06 (T. Graham) read restoring coefficient in a file - !! 3.7 ! 2015-10 (G. Madec) remove useless trends arrays - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! tra_dmp_alloc : allocate tradmp arrays - !! tra_dmp : update the tracer trend with the internal damping - !! tra_dmp_init : initialization, namlist read, parameters control - !!---------------------------------------------------------------------- - USE oce ! ocean: variables - USE dom_oce ! ocean: domain variables - USE trd_oce ! trends: ocean variables - USE trdtra ! trends manager: tracers - USE zdf_oce ! ocean: vertical physics - USE phycst ! physical constants - USE dtatsd ! data: temperature & salinity - USE zdfmxl ! vertical physics: mixed layer depth - ! - USE in_out_manager ! I/O manager - USE iom ! XIOS - USE lib_mpp ! MPP library - USE prtctl ! Print control - USE timing ! Timing - - IMPLICIT NONE - PRIVATE - - PUBLIC tra_dmp ! called by step.F90 - PUBLIC tra_dmp_init ! called by nemogcm.F90 - - ! !!* Namelist namtra_dmp : T & S newtonian damping * - LOGICAL , PUBLIC :: ln_tradmp !: internal damping flag - INTEGER , PUBLIC :: nn_zdmp !: = 0/1/2 flag for damping in the mixed layer - CHARACTER(LEN=200) , PUBLIC :: cn_resto !: name of netcdf file containing restoration coefficient field - ! - REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto !: restoring coeff. on T and S (s-1) - - !! * Substitutions -# include "do_loop_substitute.h90" -# include "domzgr_substitute.h90" - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: tradmp.F90 15574 2021-12-03 19:32:50Z techene $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - INTEGER FUNCTION tra_dmp_alloc() - !!---------------------------------------------------------------------- - !! *** FUNCTION tra_dmp_alloc *** - !!---------------------------------------------------------------------- - ALLOCATE( resto(jpi,jpj,jpk), STAT= tra_dmp_alloc ) - ! - CALL mpp_sum ( 'tradmp', tra_dmp_alloc ) - IF( tra_dmp_alloc > 0 ) CALL ctl_warn('tra_dmp_alloc: allocation of arrays failed') - ! - END FUNCTION tra_dmp_alloc - - - SUBROUTINE tra_dmp( kt, Kbb, Kmm, pts, Krhs ) - !!---------------------------------------------------------------------- - !! *** ROUTINE tra_dmp *** - !! - !! ** Purpose : Compute the tracer trend due to a newtonian damping - !! of the tracer field towards given data field and add it to the - !! general tracer trends. - !! - !! ** Method : Newtonian damping towards t_dta and s_dta computed - !! and add to the general tracer trends: - !! ta = ta + resto * (t_dta - tb) - !! sa = sa + resto * (s_dta - sb) - !! The trend is computed either throughout the water column - !! (nlmdmp=0) or in area of weak vertical mixing (nlmdmp=1) or - !! below the well mixed layer (nlmdmp=2) - !! - !! ** Action : - tsa: tracer trends updated with the damping trend - !!---------------------------------------------------------------------- - INTEGER, INTENT(in ) :: kt ! ocean time-step index - INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! time level indices - REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation - ! - INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zts_dta - REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: zwrk - REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts - !!---------------------------------------------------------------------- - ! - IF( ln_timing ) CALL timing_start('tra_dmp') - ! - IF( l_trdtra .OR. iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN !* Save ta and sa trends - ALLOCATE( ztrdts(A2D(nn_hls),jpk,jpts) ) - DO jn = 1, jpts - DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) - ztrdts(ji,jj,jk,jn) = pts(ji,jj,jk,jn,Krhs) - END_3D - END DO - ENDIF - ! !== input T-S data at kt ==! - CALL dta_tsd( kt, 'dmp', zts_dta ) ! read and interpolates T-S data at kt - ! - SELECT CASE ( nn_zdmp ) !== type of damping ==! - ! - CASE( 0 ) !* newtonian damping throughout the water column *! - DO jn = 1, jpts - DO_3D( 0, 0, 0, 0, 1, jpkm1 ) - pts(ji,jj,jk,jn,Krhs) = pts(ji,jj,jk,jn,Krhs) & - & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - pts(ji,jj,jk,jn,Kbb) ) - END_3D - END DO - ! - CASE ( 1 ) !* no damping in the turbocline (avt > 5 cm2/s) *! - DO_3D( 0, 0, 0, 0, 1, jpkm1 ) - IF( avt(ji,jj,jk) <= avt_c ) THEN - pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & - & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) - pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & - & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) - ENDIF - END_3D - ! - CASE ( 2 ) !* no damping in the mixed layer *! - DO_3D( 0, 0, 0, 0, 1, jpkm1 ) - IF( gdept(ji,jj,jk,Kmm) >= hmlp (ji,jj) ) THEN - pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & - & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) - pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & - & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) - ENDIF - END_3D - ! - END SELECT - ! - ! outputs (clem trunk) - IF( iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN - ALLOCATE( zwrk(A2D(nn_hls),jpk) ) ! Needed to handle expressions containing e3t when using key_qco or key_linssh - zwrk(:,:,:) = 0._wp - - IF( iom_use('hflx_dmp_cea') ) THEN - DO_3D( 0, 0, 0, 0, 1, jpk ) - zwrk(ji,jj,jk) = ( pts(ji,jj,jk,jp_tem,Krhs) - ztrdts(ji,jj,jk,jp_tem) ) * e3t(ji,jj,jk,Kmm) - END_3D - CALL iom_put('hflx_dmp_cea', SUM( zwrk(:,:,:), dim=3 ) * rcp * rho0 ) ! W/m2 - ENDIF - IF( iom_use('sflx_dmp_cea') ) THEN - DO_3D( 0, 0, 0, 0, 1, jpk ) - zwrk(ji,jj,jk) = ( pts(ji,jj,jk,jp_sal,Krhs) - ztrdts(ji,jj,jk,jp_sal) ) * e3t(ji,jj,jk,Kmm) - END_3D - CALL iom_put('sflx_dmp_cea', SUM( zwrk(:,:,:), dim=3 ) * rho0 ) ! g/m2/s - ENDIF - - DEALLOCATE( zwrk ) - ENDIF - ! - IF( l_trdtra ) THEN ! trend diagnostic - ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) - ztrdts(:,:,:,:) - CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) - CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) - DEALLOCATE( ztrdts ) - ENDIF - ! ! Control print - IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' dmp - Ta: ', mask1=tmask, & - & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) - ! - IF( ln_timing ) CALL timing_stop('tra_dmp') - ! - END SUBROUTINE tra_dmp - - - SUBROUTINE tra_dmp_init - !!---------------------------------------------------------------------- - !! *** ROUTINE tra_dmp_init *** - !! - !! ** Purpose : Initialization for the newtonian damping - !! - !! ** Method : read the namtra_dmp namelist and check the parameters - !!---------------------------------------------------------------------- - INTEGER :: ios, imask ! local integers - ! - NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto - !!---------------------------------------------------------------------- - ! - READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' ) - ! - READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) -902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' ) - IF(lwm) WRITE ( numond, namtra_dmp ) - ! - IF(lwp) THEN ! Namelist print - WRITE(numout,*) - WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation' - WRITE(numout,*) '~~~~~~~~~~~~' - WRITE(numout,*) ' Namelist namtra_dmp : set relaxation parameters' - WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp - WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp - WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto - WRITE(numout,*) - ENDIF - ! - IF( ln_tradmp ) THEN - ! ! Allocate arrays - IF( tra_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' ) - ! - SELECT CASE (nn_zdmp) ! Check values of nn_zdmp - CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' tracer damping as specified by mask' - CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixing layer (kz > 5 cm2/s)' - CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixed layer' - CASE DEFAULT - CALL ctl_stop('tra_dmp_init : wrong value of nn_zdmp') - END SELECT - ! - !!TG: Initialisation of dtatsd - Would it be better to have dmpdta routine - ! so can damp to something other than intitial conditions files? - !!gm: In principle yes. Nevertheless, we can't anticipate demands that have never been formulated. - IF( .NOT.ln_tsd_dmp ) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout, *) ' read T-S data not initialized, we force ln_tsd_dmp=T' - CALL dta_tsd_init( ld_tradmp=ln_tradmp ) ! forces the initialisation of T-S data - ENDIF - ! ! Read in mask from file - CALL iom_open ( cn_resto, imask) - CALL iom_get ( imask, jpdom_auto, 'resto', resto ) - CALL iom_close( imask ) - ENDIF - ! - END SUBROUTINE tra_dmp_init - - !!====================================================================== -END MODULE tradmp diff --git a/tests/ISOMIP/EXPREF/ISOMIP_mlt.png b/tests/ISOMIP/EXPREF/ISOMIP_mlt.png deleted file mode 100644 index 5435a75b3ce83568f9458cd51df0209e9b108b83..0000000000000000000000000000000000000000 Binary files a/tests/ISOMIP/EXPREF/ISOMIP_mlt.png and /dev/null differ diff --git a/tests/ISOMIP/EXPREF/ISOMIP_moc.png b/tests/ISOMIP/EXPREF/ISOMIP_moc.png deleted file mode 100644 index 5afdfbd5c5f22d809056dbdb913beef70447b0bd..0000000000000000000000000000000000000000 Binary files a/tests/ISOMIP/EXPREF/ISOMIP_moc.png and /dev/null differ diff --git a/tests/ISOMIP/EXPREF/ISOMIP_psi.png b/tests/ISOMIP/EXPREF/ISOMIP_psi.png deleted file mode 100644 index 5c46d728c3b6dc012e6ffb669f52687b2abb58cc..0000000000000000000000000000000000000000 Binary files a/tests/ISOMIP/EXPREF/ISOMIP_psi.png and /dev/null differ diff --git a/tests/ISOMIP/EXPREF/README b/tests/ISOMIP/EXPREF/README deleted file mode 100644 index 06dd530372dc213f637492d698ed8b044d1c6bc1..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/README +++ /dev/null @@ -1,25 +0,0 @@ -# ISOMIP is a simple TEST_CASE to test the iceshelves in NEMO. -# no input files are needed (all is prescribed in MY_SRC/usr_def routines -# for a reference documentation on the ISOMIP test case, see experiement 1 on http://efdl.cims.nyu.edu/project_oisi/isomip/experiments/phase_I/idealized_numerical_models_5.pdf - -# default namelist is setup for a 30y run on 32 processors with the minimum output using XIOS in attached mode with single file output - -# How to build moc.nc and psi.nc - - Download or clone the CDFTOOLS (see https://github.com/meom-group/CDFTOOLS) - - Compile all the tools (or at least cdfpsi and cdfmoc) on your cluster (see https://github.com/meom-group/CDFTOOLS#using-cdftools) - - if mesh_mask.nc is splitted, you need to rebuild them using the rebuild NEMO tools (see in NEMOGCM/TOOLS) or run 1 (or more) time step on a single processor (nn_itend variable in the namelist). - - set the correct link: ln -s mesh_mask.nc mask.nc ; ln -s mesh_mask.nc mesh_hgr.nc ; ln -s mesh_mask.nc mesh_zgr.nc - - run the cdftools : - - cdfmoc ISOMIP_1m_00010101_00301231_grid_V.nc => moc.nc - - cdfpsi ISOMIP_1m_00010101_00301231_grid_U.nc ISOMIP_1m_00010101_00301231_grid_V.nc => psi.nc - -# How to plt moc/psi and melt (python with netcdf and matplotlib library requiried): - - psi.png => python2.7 plot_psi.py -f psi.nc -v sobarstf - - moc.png => python2.7 plot_moc.py -f moc.nc -v zomsfglo - - mlt.png => python2.7 plot_mlt.py -f ISOMIP_1m_00010101_00301231_grid_T.nc -v sowflisf -by default the last time frame is plotted. - -# location the expected circulation and melt plot after 30y of run: - - ISOMIP/EXP00/ISOMIP_psi.png - - ISOMIP/EXP00/ISOMIP_moc.png - - ISOMIP/EXP00/ISOMIP_mlt.png diff --git a/tests/ISOMIP/EXPREF/axis_def_nemo.xml b/tests/ISOMIP/EXPREF/axis_def_nemo.xml deleted file mode 120000 index 6117f35baf7f6be7afa129d96a3ec521cbbc06e6..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/axis_def_nemo.xml +++ /dev/null @@ -1 +0,0 @@ -../../../cfgs/SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/tests/ISOMIP/EXPREF/context_nemo.xml b/tests/ISOMIP/EXPREF/context_nemo.xml deleted file mode 100644 index c7598d4234111d516ea10527ec9e960f89f46bdd..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/context_nemo.xml +++ /dev/null @@ -1,37 +0,0 @@ -<!-- - ============================================================================================== - NEMO context -============================================================================================== ---> -<context id="nemo"> - <!-- $id$ --> - <variable_definition> - <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 --> - <variable id="ref_year" type="int"> 1900 </variable> - <variable id="ref_month" type="int"> 01 </variable> - <variable id="ref_day" type="int"> 01 </variable> - <variable id="rho0" type="float" > 1026.0 </variable> - <variable id="cpocean" type="float" > 3991.86795711963 </variable> - <variable id="convSpsu" type="float" > 0.99530670233846 </variable> - <variable id="rhoic" type="float" > 917.0 </variable> - <variable id="rhosn" type="float" > 330.0 </variable> - <variable id="missval" type="float" > 1.e20 </variable> - </variable_definition> - -<!-- Fields definition --> - <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> - -<!-- Files definition --> - <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> - -<!-- Axis definition --> - <axis_definition src="./axis_def_nemo.xml"/> - -<!-- Domain definition --> - <domain_definition src="./domain_def_nemo.xml"/> - -<!-- Grids definition --> - <grid_definition src="./grid_def_nemo.xml"/> - - -</context> diff --git a/tests/ISOMIP/EXPREF/domain_def_nemo.xml b/tests/ISOMIP/EXPREF/domain_def_nemo.xml deleted file mode 120000 index f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/domain_def_nemo.xml +++ /dev/null @@ -1 +0,0 @@ -../../../cfgs/SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/tests/ISOMIP/EXPREF/field_def_nemo-oce.xml b/tests/ISOMIP/EXPREF/field_def_nemo-oce.xml deleted file mode 120000 index ff97068135ca98cec33e26d72ad41a072faf64b8..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/field_def_nemo-oce.xml +++ /dev/null @@ -1 +0,0 @@ -../../../cfgs/SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/tests/ISOMIP/EXPREF/file_def_nemo-oce.xml b/tests/ISOMIP/EXPREF/file_def_nemo-oce.xml deleted file mode 100644 index 77300b426d4928837c16150ea0c7c0f6c971adbc..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/file_def_nemo-oce.xml +++ /dev/null @@ -1,50 +0,0 @@ -<?xml version="1.0"?> - <!-- -============================================================================================================ -= output files definition = -= Define your own files = -= put the variables you want... = -============================================================================================================ - --> - - <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> - - <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> - <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> - <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> - <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> - <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> - <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> - - <file_group id="1d" output_freq="1d" output_level="10" enabled=".TRUE."/> <!-- 1d files --> - <file_group id="3d" output_freq="3d" output_level="10" enabled=".TRUE."/> <!-- 3d files --> - <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."> <!-- 5d files --> - - <file_group id="1m" output_freq="1mo" output_level="10" enabled=".TRUE."/> <!-- real monthly files --> - <file id="file1" output_freq="1mo" name_suffix="_grid_T" description="ocean T grid variables" > - <field field_ref="toce" name="votemper" /> - <field field_ref="soce" name="vosaline" /> - <field field_ref="ssh" name="sossheig" /> - <!-- variable for ice shelf --> - <field field_ref="fwfisf_cav" name="sowflisf" /> - <field field_ref="isfgammat" name="sogammat" /> - <field field_ref="isfgammas" name="sogammas" /> - </file> - <file id="file2" output_freq="1mo" name_suffix="_grid_U" description="ocean U grid variables" > - <field field_ref="uoce" name="vozocrtx" /> - </file> - <file id="file3" output_freq="1mo" name_suffix="_grid_V" description="ocean V grid variables" > - <field field_ref="voce" name="vomecrty" /> - </file> - </file_group> - <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> - <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> - <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> - <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> - <file_group id="1y" output_freq="1y" output_level="10" enabled=".TRUE."/> <!-- real yearly files --> - <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> - <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> - <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> - - </file_definition> - diff --git a/tests/ISOMIP/EXPREF/grid_def_nemo.xml b/tests/ISOMIP/EXPREF/grid_def_nemo.xml deleted file mode 120000 index 1be74edf6d85af6063315421809ef3994216004f..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/grid_def_nemo.xml +++ /dev/null @@ -1 +0,0 @@ -../../../cfgs/SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/tests/ISOMIP/EXPREF/iodef.xml b/tests/ISOMIP/EXPREF/iodef.xml deleted file mode 100644 index d4be5c1bd4104bfd3e1a69db33d6647804565cf9..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/iodef.xml +++ /dev/null @@ -1,26 +0,0 @@ -<?xml version="1.0"?> -<simulation> - -<!-- ============================================================================================ --> -<!-- XIOS context --> -<!-- ============================================================================================ --> - - <context id="xios" > - - <variable_definition> - - <variable id="info_level" type="int">10</variable> - <variable id="using_server" type="bool">false</variable> - <variable id="using_oasis" type="bool">false</variable> - <variable id="oasis_codes_id" type="string" >oceanx</variable> - - </variable_definition> - </context> - -<!-- ============================================================================================ --> -<!-- NEMO CONTEXT add and suppress the components you need --> -<!-- ============================================================================================ --> - - <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO --> - -</simulation> diff --git a/tests/ISOMIP/EXPREF/namelist_cfg b/tests/ISOMIP/EXPREF/namelist_cfg deleted file mode 100644 index 2358fa203d75ff6a3ed552933d4a5972aa99273e..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/namelist_cfg +++ /dev/null @@ -1,510 +0,0 @@ -!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref -!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -!! ISOMIP configuration !! -!!====================================================================== -!! *** Domain & Run management namelists *** !! -!! !! -!! namrun parameters of the run -!! namdom space and time domain -!! namcfg parameters of the configuration (default: user defined GYRE) -!! namwad Wetting and drying (default: OFF) -!! namtsd data: temperature & salinity (default: OFF) -!! namcrs coarsened grid (for outputs and/or TOP) (ln_crs =T) -!! namc1d 1D configuration options (ln_c1d =T) -!! namc1d_dyndmp 1D newtonian damping applied on currents (ln_c1d =T) -!! namc1d_uvd 1D data (currents) (ln_c1d =T) -!!====================================================================== -! -!----------------------------------------------------------------------- -&namrun ! parameters of the run -!----------------------------------------------------------------------- - cn_exp = "ISOMIP" ! experience name - nn_it000 = 1 ! first time step - nn_itend = 525600 ! last time step - nn_leapy = 0 ! Leap year calendar (1) or not (0) - ln_clobber = .true. ! clobber (overwrite) an existing file - nn_istate = 0 ! output the initial state (1) or not (0) - nn_stock = 99999999 ! frequency of creation of a restart file (modulo referenced to 1) - nn_write = 48 ! frequency of write in the output file (modulo referenced to nn_it000) - nn_istate = 0 ! output the initial state (1) or not (0) -/ -!----------------------------------------------------------------------- -&namusr_def ! ISOMIP user defined namelist -!----------------------------------------------------------------------- - ln_zps = .true. ! z-partial-step coordinate - ln_zco = .false. ! z-full-step coordinate - ln_sco = .false. ! s-coordinate - rn_e1deg = 0.3 ! zonal grid-spacing (degrees) - rn_e2deg = 0.1 ! meridional grid-spacing (degrees) - rn_e3 = 30. ! vertical resolution -/ -!----------------------------------------------------------------------- -&namdom ! time and space domain -!----------------------------------------------------------------------- - ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time - rn_Dt = 1800. ! time step for the dynamics (and tracer if nn_acc=0) -/ -!----------------------------------------------------------------------- -&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namtile ! parameters of the tiling -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&namwad ! Wetting and Drying (WaD) (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namcrs ! coarsened grid (for outputs and/or TOP) (ln_crs =T) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namc1d ! 1D configuration options (ln_c1d =T default: PAPA station) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namc1d_dyndmp ! U & V newtonian damping (ln_c1d =T default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namc1d_uvd ! data: U & V currents (ln_c1d =T default: OFF) -!----------------------------------------------------------------------- - -/ - -!!====================================================================== -!! *** Surface Boundary Condition namelists *** !! -!! !! -!! namsbc surface boundary condition manager (default: NO selection) -!! namsbc_flx flux formulation (ln_flx =T) -!! namsbc_blk Bulk formulae formulation (ln_blk =T) -!! namsbc_cpl CouPLed formulation ("key_oasis3" ) -!! namsbc_sas Stand-Alone Surface module (SAS_SRC only) -!! namsbc_iif Ice-IF: use observed ice cover (nn_ice = 1 ) -!! namtra_qsr penetrative solar radiation (ln_traqsr =T) -!! namsbc_ssr sea surface restoring term (for T and/or S) (ln_ssr =T) -!! namsbc_rnf river runoffs (ln_rnf =T) -!! namsbc_apr Atmospheric Pressure (ln_apr_dyn =T) -!! namsbc_wave external fields from wave model (ln_wave =T) -!! namberg iceberg floats (ln_icebergs=T) -!!====================================================================== -! -!----------------------------------------------------------------------- -&namsbc ! Surface Boundary Condition manager (default: NO selection) -!----------------------------------------------------------------------- - nn_fsbc = 1 ! frequency of SBC module call - ! ! (control sea-ice & iceberg model call) - ln_usr = .true. ! user defined formulation (T => check usrdef_sbc) -/ -!----------------------------------------------------------------------- -&namsbc_flx ! surface boundary condition : flux formulation (ln_flx =T) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3") -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&namsbc_iif ! Ice-IF : use observed ice cover (nn_ice = 1) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T) -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&namsbc_rnf ! runoffs (ln_rnf =T) -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&namisf ! Top boundary layer (ISF) (default: OFF) -!----------------------------------------------------------------------- - ! - ! ---------------- ice shelf load ------------------------------- - ! - ! - ! ---------------- ice shelf melt formulation ------------------------------- - ! - ln_isf = .true. ! activate ice shelf module - cn_isfdir = './' ! directory for all ice shelf input file - ! - ! ---------------- cavities opened ------------------------------- - ! - ln_isfcav_mlt = .true. ! ice shelf melting into the cavity (need ln_isfcav = .true. in domain_cfg.nc) - cn_isfcav_mlt = '2eq' ! ice shelf melting formulation (spe/2eq/3eq/oasis) - ! ! spe = fwfisf is read from a forcing field - ! ! 2eq = ISOMIP like: 2 equations formulation (Hunter et al., 2006) - ! ! 3eq = ISOMIP+ like: 3 equations formulation (Asay-Davis et al., 2015) - ! ! oasis = fwfisf is given by oasis and pattern by file sn_isfcav_fwf - ! ! cn_isfcav_mlt = 2eq or 3eq cases: - cn_gammablk = 'spe' ! scheme to compute gammat/s (spe,ad15,hj99) - ! ! ad15 = velocity dependend Gamma (u* * gammat/s) (Jenkins et al. 2010) - ! ! hj99 = velocity and stability dependent Gamma (Holland et al. 1999) - rn_gammat0 = 1.e-4 ! gammat coefficient used in blk formula - rn_gammas0 = 1.e-4 ! gammas coefficient used in blk formula - ! - rn_htbl = 30. ! thickness of the top boundary layer (Losh et al. 2008) - ! ! 0 => thickness of the tbl = thickness of the first wet cell - ! -/ -!----------------------------------------------------------------------- -&namsbc_wave ! External fields from wave model (ln_wave=T) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namberg ! iceberg parameters (default: OFF) -!----------------------------------------------------------------------- - -/ - -!!====================================================================== -!! *** Lateral boundary condition *** !! -!! !! -!! namlbc lateral momentum boundary condition (default: NO selection) -!! namagrif agrif nested grid (read by child model only) ("key_agrif") -!! nam_tide Tidal forcing (default: OFF) -!! nambdy Unstructured open boundaries (default: OFF) -!! nambdy_dta Unstructured open boundaries - external data (see nambdy) -!! nambdy_tide tidal forcing at open boundaries (default: OFF) -!!====================================================================== -! -!----------------------------------------------------------------------- -&namlbc ! lateral momentum boundary condition (default: NO selection) -!----------------------------------------------------------------------- - rn_shlat = 0. ! free slip -/ -!----------------------------------------------------------------------- -&namagrif ! AGRIF zoom ("key_agrif") -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&nam_tide ! tide parameters (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&nambdy ! unstructured open boundaries (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&nambdy_dta ! open boundaries - external data (see nam_bdy) -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&nambdy_tide ! tidal forcing at open boundaries (default: OFF) -!----------------------------------------------------------------------- -/ - -!!====================================================================== -!! *** Top/Bottom boundary condition *** !! -!! !! -!! namdrg top/bottom drag coefficient (default: NO selection) -!! namdrg_top top friction (ln_drg_OFF=F & ln_isfcav=T) -!! namdrg_bot bottom friction (ln_drg_OFF=F) -!! nambbc bottom temperature boundary condition (default: OFF) -!! nambbl bottom boundary layer scheme (default: OFF) -!!====================================================================== -! -!----------------------------------------------------------------------- -&namdrg ! top/bottom drag coefficient (default: NO selection) -!----------------------------------------------------------------------- - ln_drg_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot - ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top) - ln_non_lin = .true. ! non-linear drag: Cd = Cd0 |U| - ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| - ! - ln_drgimp = .false. ! implicit top/bottom friction flag -/ -!----------------------------------------------------------------------- -&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T) -!----------------------------------------------------------------------- - rn_Cd0 = 2.5e-3 ! drag coefficient [-] - rn_Uc0 = 0.16 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) - rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) - rn_ke0 = 0.0e-0 ! background kinetic energy [m2/s2] (non-linear cases) - rn_z0 = 3.0e-3 ! roughness [m] (ln_loglayer=T) - ln_boost = .false. ! =T regional boost of Cd0 ; =F constant - rn_boost = 50. ! local boost factor [-] -/ -!----------------------------------------------------------------------- -&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F) -!----------------------------------------------------------------------- - rn_Cd0 = 1.e-3 ! drag coefficient [-] - rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) - rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) - rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) - rn_z0 = 3.e-3 ! roughness [m] (ln_loglayer=T) - ln_boost = .false. ! =T regional boost of Cd0 ; =F constant - rn_boost = 50. ! local boost factor [-] -/ -!----------------------------------------------------------------------- -&nambbc ! bottom temperature boundary condition (default: OFF) -!----------------------------------------------------------------------- - -/ -!----------------------------------------------------------------------- -&nambbl ! bottom boundary layer scheme (default: OFF) -!----------------------------------------------------------------------- -/ - -!!====================================================================== -!! Tracer (T-S) namelists !! -!! !! -!! nameos equation of state (default: NO selection) -!! namtra_adv advection scheme (default: NO selection) -!! namtra_ldf lateral diffusion scheme (default: NO selection) -!! namtra_mle mixed layer eddy param. (Fox-Kemper param.) (default: OFF) -!! namtra_eiv eddy induced velocity param. (default: OFF) -!! namtra_dmp T & S newtonian damping (default: OFF) -!!====================================================================== -! -!----------------------------------------------------------------------- -&nameos ! ocean Equation Of Seawater (default: NO selection) -!----------------------------------------------------------------------- - ln_eos80 = .true. ! = Use EOS80 equation of state -/ -!----------------------------------------------------------------------- -&namtra_adv ! advection scheme for tracer (default: NO selection) -!----------------------------------------------------------------------- - ln_traadv_fct = .true. ! FCT scheme - nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order - nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order -/ -!----------------------------------------------------------------------- -&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) -!----------------------------------------------------------------------- - ln_traldf_lap = .true. ! laplacian operator - ln_traldf_hor = .true. ! horizontal (geopotential) - ! ! Coefficients: - nn_aht_ijk_t = 0 ! = 0 constant = 1/2 Ud*Ld (lap case) - rn_Ud = 0.02 ! lateral diffusive velocity [m/s] - rn_Ld = 10.e+3 ! lateral diffusive length [m] -/ -!----------------------------------------------------------------------- -&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namtra_eiv ! eddy induced velocity param. (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namtra_dmp ! tracer: T & S newtonian damping (default: OFF) -!----------------------------------------------------------------------- -/ - -!!====================================================================== -!! *** Dynamics namelists *** !! -!! !! -!! nam_vvl vertical coordinate options (default: z-star) -!! namdyn_adv formulation of the momentum advection (default: NO selection) -!! namdyn_vor advection scheme (default: NO selection) -!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) -!! namdyn_spg surface pressure gradient (default: NO selection) -!! namdyn_ldf lateral diffusion scheme (default: NO selection) -!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) -!!====================================================================== -! -!----------------------------------------------------------------------- -&nam_vvl ! vertical coordinate options (default: z-star) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namdyn_adv ! formulation of the momentum advection (default: NO selection) -!----------------------------------------------------------------------- - ln_dynadv_vec = .true. ! vector form (T) or flux form (F) - nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction -/ -!----------------------------------------------------------------------- -&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) -!----------------------------------------------------------------------- - ln_dynvor_ene = .true. ! energy conserving scheme -/ -!----------------------------------------------------------------------- -&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) -!----------------------------------------------------------------------- - ln_hpg_isf = .true. ! s-coordinate adapted for isf (standard jacobian formulation) -/ -!----------------------------------------------------------------------- -&namdyn_spg ! surface pressure gradient (default: NO selection) -!----------------------------------------------------------------------- - ln_dynspg_ts = .true. ! split-explicit free surface -/ -!----------------------------------------------------------------------- -&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) -!----------------------------------------------------------------------- - ln_dynldf_lap = .true. ! laplacian operator - ln_dynldf_lev = .true. ! iso-level - nn_ahm_ijk_t = 0 ! = 0 constant = 1/2 Uv*Lv (lap case) - rn_Uv = 0.12 ! lateral viscous velocity [m/s] - rn_Lv = 10.e+3 ! lateral viscous length [m] -/ -!----------------------------------------------------------------------- -&namdta_dyn ! offline ocean input files (OFF_SRC only) -!----------------------------------------------------------------------- - -/ - -!!====================================================================== -!! vertical physics namelists !! -!! !! -!! namzdf vertical physics manager (default: NO selection) -!! namzdf_ric richardson number vertical mixing (ln_zdfric=T) -!! namzdf_tke TKE vertical mixing (ln_zdftke=T) -!! namzdf_gls GLS vertical mixing (ln_zdfgls=T) -!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T) -!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T) -!!====================================================================== -! -!----------------------------------------------------------------------- -&namzdf ! vertical physics manager (default: NO selection) -!----------------------------------------------------------------------- - ! ! type of vertical closure (required) - ln_zdfcst = .true. ! constant mixing - ! - ! ! convection - ln_zdfevd = .true. ! enhanced vertical diffusion - rn_evd = 0.1 ! mixing coefficient [m2/s] - ! - ! ! coefficients - rn_avm0 = 1.e-3 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst) - rn_avt0 = 5.e-5 ! vertical eddy diffusivity [m2/s] (background Kz if ln_zdfcst) -/ -!----------------------------------------------------------------------- -&namzdf_ric ! richardson number dependent vertical diffusion (ln_zdfric =T) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namzdf_osm ! OSM vertical diffusion (ln_zdfosm =T) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T) -!----------------------------------------------------------------------- -/ - -!!====================================================================== -!! *** Diagnostics namelists *** !! -!! !! -!! namtrd dynamics and/or tracer trends (default: OFF) -!! namhsb Heat and salt budgets (default: OFF) -!! namdiu Cool skin and warm layer models (default: OFF) -!! namdiu Cool skin and warm layer models (default: OFF) -!! namflo float parameters (default: OFF) -!! nam_diadct transports through some sections (default: OFF) -!! nam_dia25h 25h Mean Output (default: OFF) -!! namnc4 netcdf4 chunking and compression settings ("key_netcdf4") -!!====================================================================== -! -!----------------------------------------------------------------------- -&namtrd ! trend diagnostics (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namhsb ! Heat and salt budgets (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namdiu ! Cool skin and warm layer models (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namflo ! float parameters ("key_float") -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&nam_diaharm ! Harmonic analysis of tidal constituents ("key_diaharm") -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namdct ! transports through some sections ("key_diadct") -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&nam_diatmb ! Top Middle Bottom Output (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&nam_dia25h ! 25h Mean Output (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4") -!----------------------------------------------------------------------- -/ - -!!====================================================================== -!! *** Observation & Assimilation *** !! -!! !! -!! namobs observation and model comparison (default: OFF) -!! nam_asminc assimilation increments ('key_asminc') -!!====================================================================== -! -!----------------------------------------------------------------------- -&namobs ! observation usage switch (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&nam_asminc ! assimilation increments ('key_asminc') -!----------------------------------------------------------------------- -/ - -!!====================================================================== -!! *** Miscellaneous namelists *** !! -!! !! -!! nammpp Massively Parallel Processing -!! namctl Control prints (default: OFF) -!! namsto Stochastic parametrization of EOS (default: OFF) -!!====================================================================== -! -!----------------------------------------------------------------------- -&nammpp ! Massively Parallel Processing -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namctl ! Control prints (default: OFF) -!----------------------------------------------------------------------- -/ -!----------------------------------------------------------------------- -&namsto ! Stochastic parametrization of EOS (default: OFF) -!----------------------------------------------------------------------- -/ diff --git a/tests/ISOMIP/EXPREF/namelist_ref b/tests/ISOMIP/EXPREF/namelist_ref deleted file mode 120000 index 97682863712c9d973a2d1aa35a12452a3e8b4f96..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/namelist_ref +++ /dev/null @@ -1 +0,0 @@ -../../../cfgs/SHARED/namelist_ref \ No newline at end of file diff --git a/tests/ISOMIP/EXPREF/plot_mlt.py b/tests/ISOMIP/EXPREF/plot_mlt.py deleted file mode 100644 index edb9e04afe6a73d309ca73ecf5922344e4c0c060..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/plot_mlt.py +++ /dev/null @@ -1,47 +0,0 @@ -from netCDF4 import Dataset -import numpy as np -from numpy import ma -import argparse -import matplotlib.pyplot as plt -import matplotlib - -parser = argparse.ArgumentParser() -parser.add_argument("-f" , metavar='file_name' , help="names of input files" , type=str , nargs="+", required=True ) -parser.add_argument("-v" , metavar='var_name' , help="variable list" , type=str , nargs=1 , required=True ) -args = parser.parse_args() - -# read mesh_mask -ncid = Dataset('mesh_mask.nc') -lat2d = ncid.variables['gphit' ][ :,:].squeeze() -lon2d = ncid.variables['glamt' ][ :,:].squeeze() -msk = ncid.variables['tmaskutil'][0,:,:].squeeze() -ncid.close() - -plt.figure(figsize=np.array([210,210]) / 25.4) - -# read psi.nc -ncid = Dataset(args.f[0]) -var2d = ncid.variables[args.v[0]][-1,:,:].squeeze() -var2dm = ma.masked_where(msk==0.0,var2d) -# convert in m/y -var2dm = var2dm * 86400 * 365 / 1e3 -ncid.close() - -# define colorbar -vlevel=np.arange(-1.6,1.8,0.2) -pcol = plt.contourf(lon2d,lat2d,var2dm,levels=vlevel,extend='both') -vlevel=np.arange(-1.6,1.8,0.4) -matplotlib.rcParams['contour.negative_linestyle'] = 'solid' -plt.contour(lon2d,lat2d,var2dm,levels=vlevel,colors='k') -plt.grid() -plt.title('melt rate ISOMIP (m/y)') -plt.ylabel('Latitude',fontsize=14) -plt.xlabel('Longitude',fontsize=14) -cbar = plt.colorbar(pcol, ticks=vlevel) -cbar.ax.tick_params(labelsize=14) - -# save figure -plt.savefig('mlt.png', format='png', dpi=300) - -plt.show() - diff --git a/tests/ISOMIP/EXPREF/plot_moc.py b/tests/ISOMIP/EXPREF/plot_moc.py deleted file mode 100644 index f8fc48e811b92f6c2d44cb70942afe119d228242..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/plot_moc.py +++ /dev/null @@ -1,60 +0,0 @@ -from netCDF4 import Dataset -import numpy as np -import argparse -import matplotlib.pyplot as plt - -# read argument -parser = argparse.ArgumentParser() -parser.add_argument("-f" , metavar='file_name' , help="names of input files" , type=str , nargs=1 , required=True ) -parser.add_argument("-v" , metavar='var_name' , help="variable list" , type=str , nargs=1 , required=True ) -args = parser.parse_args() - -# read mesh mask -ncid = Dataset('mesh_mask.nc') -vx2d = ncid.variables['gphit' ][0,:,0].squeeze() -vx2dv = ncid.variables['gphiv' ][0,:,0].squeeze() -y2d = ncid.variables['gdepw_0'][0,:,:,1].squeeze()*-1 -y2dt = ncid.variables['gdept_0'][0,:,:,1].squeeze()*-1 -msk = ncid.variables['tmask' ][0,:,:,1].squeeze() -ncid.close() - -# build x 2d array -x2d=y2d*0.0 -x2dv=y2d*0.0 -for jk in range(0,y2d.shape[0]): - x2d[jk,:]=vx2d[:] - x2dv[jk,:]=vx2d[:] - -plt.figure(figsize=np.array([210,210]) / 25.4) - -# read data and mask it -ncid = Dataset(args.f[0]) -var2d = ncid.variables[args.v[0]][-1,:,:,:].squeeze() -var2dm = var2d[:,:] -var2dm[msk==0] = -1 -ncid.close() - -# define colorbar -vlevel=np.arange(0,0.13,0.01) -pcol = plt.contourf(x2d,y2d,var2dm,levels=vlevel) -plt.clf() - -# plot contour -ax = plt.subplot(1, 1, 1) -ax.contour(x2dv,y2dt,var2dm,levels=vlevel) -ax.grid() -ax.set_title('MOC ISOMIP (Sv)') -ax.set_ylabel('Depth (m)',fontsize=14) -ax.set_xlabel('Latitude',fontsize=14) - -# plot colorbar -plt.subplots_adjust(left=0.1,right=0.89, bottom=0.1, top=0.89, wspace=0.1, hspace=0.1) -cax = plt.axes([0.91, 0.1, 0.02, 0.79]) -cbar= plt.colorbar(pcol, ticks=vlevel, cax=cax) -cbar.ax.tick_params(labelsize=14) - -# save figure -plt.savefig('moc.png', format='png', dpi=300) - -plt.show() - diff --git a/tests/ISOMIP/EXPREF/plot_psi.py b/tests/ISOMIP/EXPREF/plot_psi.py deleted file mode 100644 index 16b615fdad922cd8f0cd41591e937a7e9f5d909d..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/EXPREF/plot_psi.py +++ /dev/null @@ -1,52 +0,0 @@ -from netCDF4 import Dataset -import numpy as np -from numpy import ma -import argparse -import matplotlib.pyplot as plt - -parser = argparse.ArgumentParser() -parser.add_argument("-f" , metavar='file_name' , help="names of input files" , type=str , nargs="+", required=True ) -parser.add_argument("-v" , metavar='var_name' , help="variable list" , type=str , nargs=1 , required=True ) -args = parser.parse_args() - -# read mesh_mask -ncid = Dataset('mesh_mask.nc') -lat2d = ncid.variables['gphit' ][ :,:].squeeze() -lon2d = ncid.variables['glamt' ][ :,:].squeeze() -msk = ncid.variables['tmaskutil'][0,:,:].squeeze() -ncid.close() - -plt.figure(figsize=np.array([210,210]) / 25.4) - -# read psi.nc -ncid = Dataset(args.f[0]) -var2d = ncid.variables[args.v[0]][-1,:,:].squeeze() -var2dm = ma.masked_where(msk==0.0,var2d) -# convert in Sv -var2dm = var2dm / 1e6 -ncid.close() - -# define colorbar -vlevel=np.arange(0.00,0.36,0.02) -pcol = plt.contourf(lon2d,lat2d,var2dm,levels=vlevel) -plt.clf() - -# plot contour -ax = plt.subplot(1, 1, 1) -ax.contour(lon2d,lat2d,var2dm,levels=vlevel) -ax.grid() -ax.set_title('PSI ISOMIP (Sv)') -ax.set_ylabel('Latitude',fontsize=14) -ax.set_xlabel('Longitude',fontsize=14) - -# plot colorbar -plt.subplots_adjust(left=0.1,right=0.89, bottom=0.1, top=0.89, wspace=0.1, hspace=0.1) -cax = plt.axes([0.91, 0.1, 0.02, 0.79]) -cbar= plt.colorbar(pcol, ticks=vlevel, cax=cax) -cbar.ax.tick_params(labelsize=14) - -# save figure -plt.savefig('psi.png', format='png', dpi=300) - -plt.show() - diff --git a/tests/ISOMIP/MY_SRC/usrdef_hgr.F90 b/tests/ISOMIP/MY_SRC/usrdef_hgr.F90 deleted file mode 100644 index bda6366cbb8dd3bc41a03676bc1cbcb42c43ede2..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/MY_SRC/usrdef_hgr.F90 +++ /dev/null @@ -1,119 +0,0 @@ -MODULE usrdef_hgr - !!====================================================================== - !! *** MODULE usrdef_hgr *** - !! - !! === LOCK_EXCHANGE configuration === - !! - !! User defined : mesh and Coriolis parameter of a user configuration - !!====================================================================== - !! History : NEMO ! 2016-08 (S. Flavoni, G. Madec) Original code - !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! usr_def_hgr : initialize the horizontal mesh for ISOMIP configuration - !!---------------------------------------------------------------------- - USE dom_oce - USE par_oce ! ocean space and time domain - USE phycst ! physical constants - USE usrdef_nam, ONLY: rn_e1deg, rn_e2deg ! horizontal resolution in meters - ! - USE in_out_manager ! I/O manager - USE lib_mpp ! MPP library - - IMPLICIT NONE - PRIVATE - - PUBLIC usr_def_hgr ! called by domhgr.F90 - - !! * Substitutions -# include "do_loop_substitute.h90" - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: usrdef_hgr.F90 14223 2020-12-19 10:22:45Z smasson $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE usr_def_hgr( plamt , plamu , plamv , plamf , & ! geographic position (required) - & pphit , pphiu , pphiv , pphif , & ! - & kff , pff_f , pff_t , & ! Coriolis parameter (if domain not on the sphere) - & pe1t , pe1u , pe1v , pe1f , & ! scale factors (required) - & pe2t , pe2u , pe2v , pe2f , & ! - & ke1e2u_v , pe1e2u , pe1e2v ) ! u- & v-surfaces (if gridsize reduction is used in strait(s)) - !!---------------------------------------------------------------------- - !! *** ROUTINE usr_def_hgr *** - !! - !! ** Purpose : user defined mesh and Coriolis parameter - !! - !! ** Method : set all intent(out) argument to a proper value - !! ISOMIP configuration - !! - !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees) - !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters) - !! - define u- & v-surfaces (in m2) - !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs [degrees] - REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs [degrees] - INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter computed here, =0 otherwise - REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point [1/s] - REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1v, pe1f ! i-scale factors [m] - REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2u, pe2v, pe2f ! j-scale factors [m] - INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces computed here, =0 otherwise - REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] - ! - INTEGER :: ji, jj ! dummy loop indices - REAL(wp) :: zfact, zti, zui, zvi, zfi, ztj, zuj, zvj, zfj ! local scalars - !!------------------------------------------------------------------------------- - ! - IF(lwp) THEN - WRITE(numout,*) - WRITE(numout,*) 'usr_def_hgr : ISOMIP configuration' - WRITE(numout,*) '~~~~~~~~~~~' - WRITE(numout,*) - WRITE(numout,*) ' ===>> geographical mesh on the sphere with regular grid-spacing' - WRITE(numout,*) ' given by rn_e1deg and rn_e2deg' - ENDIF - ! - ! !== grid point position ==! (in degrees) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! ! longitude (west coast at lon=0°) - plamt(ji,jj) = rn_e1deg * ( - 0.5 + REAL( mig(ji,0)-1 , wp ) ) - plamu(ji,jj) = rn_e1deg * ( REAL( mig(ji,0)-1 , wp ) ) - plamv(ji,jj) = plamt(ji,jj) - plamf(ji,jj) = plamu(ji,jj) - ! ! latitude (south coast at lat=-80°) - pphit(ji,jj) = rn_e2deg * ( - 0.5 + REAL( mjg(jj,0)-1 , wp ) ) - 80._wp - pphiu(ji,jj) = pphit(ji,jj) - pphiv(ji,jj) = rn_e2deg * ( REAL( mjg(jj,0)-1 , wp ) ) - 80._wp - pphif(ji,jj) = pphiv(ji,jj) - END_2D - ! - ! !== Horizontal scale factors ==! (in meters) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - ! ! e1 (zonal) - pe1t(ji,jj) = ra * rad * COS( rad * pphit(ji,jj) ) * rn_e1deg - pe1u(ji,jj) = ra * rad * COS( rad * pphiu(ji,jj) ) * rn_e1deg - pe1v(ji,jj) = ra * rad * COS( rad * pphiv(ji,jj) ) * rn_e1deg - pe1f(ji,jj) = ra * rad * COS( rad * pphif(ji,jj) ) * rn_e1deg - ! ! e2 (meridional) - pe2t(ji,jj) = ra * rad * rn_e2deg - pe2u(ji,jj) = ra * rad * rn_e2deg - pe2v(ji,jj) = ra * rad * rn_e2deg - pe2f(ji,jj) = ra * rad * rn_e2deg - END_2D - ! ! NO reduction of grid size in some straits - ke1e2u_v = 0 ! ==>> u_ & v_surfaces will be computed in dom_ghr routine - pe1e2u(:,:) = 0._wp ! CAUTION: set to zero to avoid error with some compilers that - pe1e2v(:,:) = 0._wp ! require an initialization of INTENT(out) arguments - ! - ! - ! !== Coriolis parameter ==! - kff = 0 ! Coriolis parameter calculated on the sphere - pff_f(:,:) = 0._wp ! CAUTION: set to zero to avoid error with some compilers that - pff_t(:,:) = 0._wp ! require an initialization of INTENT(out) arguments - ! - END SUBROUTINE usr_def_hgr - - !!====================================================================== -END MODULE usrdef_hgr diff --git a/tests/ISOMIP/MY_SRC/usrdef_istate.F90 b/tests/ISOMIP/MY_SRC/usrdef_istate.F90 deleted file mode 100644 index 42cf30fd2d67ddbb8fa411873beec23c58de5c9c..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/MY_SRC/usrdef_istate.F90 +++ /dev/null @@ -1,87 +0,0 @@ -MODULE usrdef_istate - !!====================================================================== - !! *** MODULE usrdef_istate *** - !! - !! === ISOMIP configuration === - !! - !! User defined : set the initial state of a user configuration - !!====================================================================== - !! History : NEMO ! 2016-11 (S. Flavoni) Original code - !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case - !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! usr_def_istate : initial state in Temperature and salinity - !!---------------------------------------------------------------------- - USE par_oce ! ocean space and time domain - USE dom_oce , ONLY : glamt - USE phycst ! physical constants - ! - USE in_out_manager ! I/O manager - USE lib_mpp ! MPP library - - IMPLICIT NONE - PRIVATE - - PUBLIC usr_def_istate ! called by istate.F90 - PUBLIC usr_def_istate_ssh ! called by domqco.F90 - - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: usrdef_istate.F90 14053 2020-12-03 13:48:38Z techene $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) - !!---------------------------------------------------------------------- - !! *** ROUTINE usr_def_istate *** - !! - !! ** Purpose : Initialization of the dynamics and tracers - !! Here ISOMIP configuration - !! - !! ** Method : - set temperature field - !! - set salinity field - !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] - REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] - REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] - REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] - REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] - !!---------------------------------------------------------------------- - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'usr_def_istate : ISOMIP configuration, analytical definition of initial state' - IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with a constant salinity and temperature. ' - pu (:,:,:) = 0._wp ! ocean at rest - pv (:,:,:) = 0._wp - ! ! T & S profiles - pts(:,:,:,jp_tem) = - 1.9 * ptmask(:,:,:) ! ISOMIP configuration : start from constant T+S fields - pts(:,:,:,jp_sal) = 34.4 * ptmask(:,:,:) - ! - END SUBROUTINE usr_def_istate - - - SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) - !!---------------------------------------------------------------------- - !! *** ROUTINE usr_def_istate_ssh *** - !! - !! ** Purpose : Initialization of ssh - !! Here ISOMIP configuration - !! - !! ** Method : set ssh to 0 - !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] - REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] - !!---------------------------------------------------------------------- - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : ISOMIP configuration, analytical definition of initial state' - ! - pssh(:,:) = 0._wp - ! - END SUBROUTINE usr_def_istate_ssh - - !!====================================================================== -END MODULE usrdef_istate diff --git a/tests/ISOMIP/MY_SRC/usrdef_nam.F90 b/tests/ISOMIP/MY_SRC/usrdef_nam.F90 deleted file mode 100644 index b10630838bb8cb52d6067d92a147d7686e169e36..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/MY_SRC/usrdef_nam.F90 +++ /dev/null @@ -1,108 +0,0 @@ -MODULE usrdef_nam - !!====================================================================== - !! *** MODULE usrdef_nam *** - !! - !! === ISOMIP configuration === - !! - !! User defined : set the domain characteristics of a user configuration - !!====================================================================== - !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) Original code - !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! usr_def_nam : read user defined namelist and set global domain size - !! usr_def_hgr : initialize the horizontal mesh - !!---------------------------------------------------------------------- - USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate - USE par_oce ! ocean space and time domain - USE phycst ! physical constants - ! - USE in_out_manager ! I/O manager - USE lib_mpp ! MPP library - USE timing ! Timing - - IMPLICIT NONE - PRIVATE - - PUBLIC usr_def_nam ! called by nemogcm.F90 - - ! !!* namusr_def namelist *!! - REAL(wp), PUBLIC :: rn_e1deg, rn_e2deg !: horizontal resolution [degrees] - REAL(wp), PUBLIC :: rn_e3 !: vertical resolution [m] - - REAL(wp), PARAMETER, PUBLIC :: rbathy = 900._wp !: depth of the seafloor [m] - - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: usrdef_nam.F90 14433 2021-02-11 08:06:49Z smasson $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) - !!---------------------------------------------------------------------- - !! *** ROUTINE dom_nam *** - !! - !! ** Purpose : read user defined namelist and define the domain size - !! - !! ** Method : read in namusr_def containing all the user specific namelist parameter - !! - !! Here ISOMIP configuration - !! - !! ** input : - namusr_def namelist found in namelist_cfg - !!---------------------------------------------------------------------- - CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name - INTEGER , INTENT(out) :: kk_cfg ! configuration resolution - INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes - LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity - LOGICAL , INTENT(out) :: ldNFold ! North pole folding - CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F - ! - INTEGER :: ios ! Local integer - !! - NAMELIST/namusr_def/ ln_zco, ln_zps, ln_sco, rn_e1deg, rn_e2deg, rn_e3 - !!---------------------------------------------------------------------- - ! - READ ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 902 ) -902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namusr_def in configuration namelist' ) - ! - IF(lwm) WRITE( numond, namusr_def ) - ! - cd_cfg = 'ISOMIP' ! name & resolution (not used) - kk_cfg = INT( rn_e3 ) - ! - ! Global Domain size: ISOMIP domain is 15° x 10° x 900 m - kpi = INT( 15.0 / rn_e1deg ) + 2 ! add 2 for t-point in the east & west coasts - kpj = INT( 10.0 / rn_e2deg ) + 2 ! - - north & south - - kpk = INT( rbathy / rn_e3 ) + 1 ! add 1 for t-point in the seafloor - ! - ! ! Set the lateral boundary condition of the global domain - ldIperio = .FALSE. ; ldJperio = .FALSE. ! ISOMIP configuration : closed domain - ldNFold = .FALSE. ; cdNFtype = '-' - ! - ! ! control print - IF(lwp) THEN - WRITE(numout,*) ' ' - WRITE(numout,*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg' - WRITE(numout,*) '~~~~~~~~~~~ ' - WRITE(numout,*) ' Namelist namusr_def : ISOMIP test case' - WRITE(numout,*) ' type of vertical coordinate : ' - WRITE(numout,*) ' z-coordinate flag ln_zco = ', ln_zco - WRITE(numout,*) ' z-partial-step coordinate flag ln_zps = ', ln_zps - WRITE(numout,*) ' s-coordinate flag ln_sco = ', ln_sco - WRITE(numout,*) ' resolution' - WRITE(numout,*) ' zonal resolution rn_e1deg = ', rn_e1deg, ' degrees' - WRITE(numout,*) ' meridional resolution rn_e1deg = ', rn_e1deg, ' degrees' - WRITE(numout,*) ' vertical resolution rn_e3 = ', rn_e3 , ' meters' - WRITE(numout,*) ' ISOMIP domain = 15° x 10° x 900 m' - WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi - WRITE(numout,*) ' Nj0glo = ', kpj - WRITE(numout,*) ' jpkglo = ', kpk - WRITE(numout,*) ' ' - ENDIF - ! - END SUBROUTINE usr_def_nam - - !!====================================================================== -END MODULE usrdef_nam diff --git a/tests/ISOMIP/MY_SRC/usrdef_sbc.F90 b/tests/ISOMIP/MY_SRC/usrdef_sbc.F90 deleted file mode 100644 index b3ff303a842d5898dd4f39d91aaa6ed5e0a65757..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/MY_SRC/usrdef_sbc.F90 +++ /dev/null @@ -1,90 +0,0 @@ -MODULE usrdef_sbc - !!====================================================================== - !! *** MODULE usrdef_sbc *** - !! - !! === ISOMIP configuration === - !! - !! User defined : surface forcing of a user configuration - !!====================================================================== - !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface - !! ! 2017-02 (P. Mathiot, S. Flavoni) adapt code to ISOMIP case - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! usr_def_sbc : user defined surface bounday conditions in ISOMIP case - !!---------------------------------------------------------------------- - USE oce ! ocean dynamics and tracers - USE dom_oce ! ocean space and time domain - USE sbc_oce ! Surface boundary condition: ocean fields - USE sbc_ice ! Surface boundary condition: ice fields - USE phycst ! physical constants - ! - USE in_out_manager ! I/O manager - USE lib_mpp ! distribued memory computing library - USE lbclnk ! ocean lateral boundary conditions (or mpp link) - USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) - - IMPLICIT NONE - PRIVATE - - PUBLIC usrdef_sbc_oce ! routine called in sbcmod module - PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics - PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo - - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: usrdef_sbc.F90 12377 2020-02-12 14:39:06Z acc $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE usrdef_sbc_oce( kt, Kbb ) - !!--------------------------------------------------------------------- - !! *** ROUTINE usr_def_sbc *** - !! - !! ** Purpose : provide at each time-step the surface boundary - !! condition, i.e. the momentum, heat and freshwater fluxes. - !! - !! ** Method : all 0 fields, for ISOMIP case - !! CAUTION : never mask the surface stress field ! - !! - !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e. - !! utau, vtau, taum, wndm, qns, qsr, emp, sfx - !! - !!---------------------------------------------------------------------- - INTEGER, INTENT(in) :: kt ! ocean time step - INTEGER, INTENT(in) :: Kbb ! ocean time index - !!--------------------------------------------------------------------- - ! - IF( kt == nit000 ) THEN - ! - IF(lwp) WRITE(numout,*)' usr_sbc : ISOMIP case: NO surface forcing' - IF(lwp) WRITE(numout,*)' ~~~~~~~~~~~ utau = vtau = taum = wndm = qns = qsr = emp = sfx = 0' - ! - utau(:,:) = 0._wp - vtau(:,:) = 0._wp - taum(:,:) = 0._wp - wndm(:,:) = 0._wp - ! - emp (:,:) = 0._wp - sfx (:,:) = 0._wp - qns (:,:) = 0._wp - qsr (:,:) = 0._wp - ! - ENDIF - ! - END SUBROUTINE usrdef_sbc_oce - - SUBROUTINE usrdef_sbc_ice_tau( kt ) - INTEGER, INTENT(in) :: kt ! ocean time step - END SUBROUTINE usrdef_sbc_ice_tau - - - SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi ) - INTEGER, INTENT(in) :: kt ! ocean time step - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness - END SUBROUTINE usrdef_sbc_ice_flx - - !!====================================================================== -END MODULE usrdef_sbc diff --git a/tests/ISOMIP/MY_SRC/usrdef_zgr.F90 b/tests/ISOMIP/MY_SRC/usrdef_zgr.F90 deleted file mode 100644 index 60e89b6fca163edf6ebcdcc196d2c5ca93f03772..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/MY_SRC/usrdef_zgr.F90 +++ /dev/null @@ -1,235 +0,0 @@ -MODULE usrdef_zgr - !!====================================================================== - !! *** MODULE usrdef_zgr *** - !! - !! === ISOMIP case === - !! - !! user defined : vertical coordinate system of a user configuration - !!====================================================================== - !! History : 4.0 ! 2016-08 (G. Madec, S. Flavoni) Original code - !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! usr_def_zgr : user defined vertical coordinate system (required) - !! zgr_z1d : reference 1D z-coordinate - !!--------------------------------------------------------------------- - USE oce ! ocean variables - USE dom_oce ! ocean space and time domain - USE usrdef_nam ! User defined : namelist variables - ! - USE in_out_manager ! I/O manager - USE lbclnk ! ocean lateral boundary conditions (or mpp link) - USE lib_mpp ! distributed memory computing library - USE timing ! Timing - - IMPLICIT NONE - PRIVATE - - PUBLIC usr_def_zgr ! called by domzgr.F90 - - !! * Substitutions -# include "do_loop_substitute.h90" - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: usrdef_zgr.F90 13295 2020-07-10 18:24:21Z acc $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate - & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate - & pdept , pdepw , & ! 3D t & w-points depth - & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors - & pe3w , pe3uw , pe3vw, & ! - - - - & k_top , k_bot ) ! top & bottom ocean level - !!--------------------------------------------------------------------- - !! *** ROUTINE usr_def_zgr *** - !! - !! ** Purpose : User defined the vertical coordinates - !! - !!---------------------------------------------------------------------- - LOGICAL , INTENT(in ) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags ( read in namusr_def ) - LOGICAL , INTENT( out) :: ld_isfcav ! under iceshelf cavity flag - REAL(wp), DIMENSION(:) , INTENT( out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] - REAL(wp), DIMENSION(:) , INTENT( out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] - REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdept, pdepw ! grid-point depth [m] - REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] - REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3w , pe3uw, pe3vw ! i-scale factors - INTEGER , DIMENSION(:,:) , INTENT( out) :: k_top, k_bot ! first & last ocean level - ! - INTEGER :: ji , jj, jk ! dummy indices - INTEGER :: ij0, ij1 ! dummy indices - INTEGER :: ik ! local integers - REAL(wp) :: zfact, z1_jpkm1 ! local scalar - REAL(wp) :: ze3min, zdepth ! local scalar - REAL(wp), DIMENSION(jpi,jpj) :: zht , zhu ! bottom depth - REAL(wp), DIMENSION(jpi,jpj) :: zhisf, zhisfu ! top depth - !!---------------------------------------------------------------------- - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'usr_def_zgr : ISOMIP configuration (z(ps)- or s-coordinate closed box ocean without cavities)' - IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' - ! - ! - ! type of vertical coordinate - ! --------------------------- - ! set in usrdef_nam.F90 by reading the namusr_def namelist except for ISF - ld_isfcav = .TRUE. ! ISF Ice Shelves Flag - ! - ! - ! Build the vertical coordinate system - ! ------------------------------------ - ! - ! !== isfdraft ==! - ! - zht (:,:) = rbathy - zhisf(:,:) = 200._wp - ij0 = 1 ; ij1 = 40+nn_hls - DO jj = mj0(ij0,nn_hls), mj1(ij1,nn_hls) - zhisf(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp - END DO - ! - CALL zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system - ! - ! !== top masked level bathymetry ==! (all coordinates) - ! - IF ( ld_zps ) THEN !== zps-coordinate ==! (partial bottom-steps) - ! - ze3min = 0.1_wp * rn_e3 - IF(lwp) WRITE(numout,*) ' minimum thickness of the partial cells = 10 % of e3 = ', ze3min - ! - ! !* bottom ocean compute from the depth of grid-points - k_bot(:,:) = jpkm1 - DO jk = jpkm1, 1, -1 - WHERE( zht(:,:) < pdepw_1d(jk) + ze3min ) k_bot(:,:) = jk-1 - END DO - ! !* top ocean compute from the depth of grid-points - k_top(:,:) = 1 ! - DO jk = 2, jpkm1 - zdepth = pdepw_1d(jk+1) - ze3min - WHERE( zhisf(:,:) > 0.0 .AND. zhisf(:,:) >= zdepth ) k_top(:,:) = (jk + 1) - END DO - ! - ! !* vertical coordinate system - DO jk = 1, jpk ! initialization to the reference z-coordinate - pdept(:,:,jk) = pdept_1d(jk) - pdepw(:,:,jk) = pdepw_1d(jk) - pe3t (:,:,jk) = pe3t_1d (jk) - pe3u (:,:,jk) = pe3t_1d (jk) - pe3v (:,:,jk) = pe3t_1d (jk) - pe3f (:,:,jk) = pe3t_1d (jk) - pe3w (:,:,jk) = pe3w_1d (jk) - pe3uw(:,:,jk) = pe3w_1d (jk) - pe3vw(:,:,jk) = pe3w_1d (jk) - END DO - ! top scale factors and depth at T- and W-points - DO_2D( 1, 1, 1, 1 ) - ik = k_top(ji,jj) - IF ( ik > 2 ) THEN - ! pdeptw at the interface - pdepw(ji,jj,ik ) = MAX( zhisf(ji,jj) , pdepw(ji,jj,ik) ) - ! e3t in both side of the interface - pe3t (ji,jj,ik ) = pdepw(ji,jj,ik+1) - pdepw(ji,jj,ik) - ! pdept in both side of the interface (from previous e3t) - pdept(ji,jj,ik ) = pdepw(ji,jj,ik ) + pe3t (ji,jj,ik ) * 0.5_wp - pdept(ji,jj,ik-1) = pdepw(ji,jj,ik ) - pe3t (ji,jj,ik ) * 0.5_wp - ! pe3w on both side of the interface - pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik ) - pe3w (ji,jj,ik ) = pdept(ji,jj,ik ) - pdept(ji,jj,ik-1) - ! e3t into the ice shelf - pe3t (ji,jj,ik-1) = pdepw(ji,jj,ik ) - pdepw(ji,jj,ik-1) - pe3w (ji,jj,ik-1) = pdept(ji,jj,ik-1) - pdept(ji,jj,ik-2) - END IF - END_2D - ! bottom scale factors and depth at T- and W-points - DO_2D( 1, 1, 1, 1 ) - ik = k_bot(ji,jj) - pdepw(ji,jj,ik+1) = MIN( zht(ji,jj) , pdepw_1d(ik+1) ) - pe3t (ji,jj,ik ) = pdepw(ji,jj,ik+1) - pdepw(ji,jj,ik) - pe3t (ji,jj,ik+1) = pe3t (ji,jj,ik ) - ! - pdept(ji,jj,ik ) = pdepw(ji,jj,ik ) + pe3t (ji,jj,ik ) * 0.5_wp - pdept(ji,jj,ik+1) = pdepw(ji,jj,ik+1) + pe3t (ji,jj,ik+1) * 0.5_wp - pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik) - END_2D - ! ! bottom scale factors and depth at U-, V-, UW and VW-points - pe3u (:,:,:) = pe3t(:,:,:) - pe3uw(:,:,:) = pe3w(:,:,:) - DO_3D( 0, 0, 0, 0, 1, jpk ) - ! ! Computed as the minimum of neighbooring scale factors - pe3v (ji,jj,jk) = MIN( pe3t(ji,jj,jk), pe3t(ji,jj+1,jk) ) - pe3vw(ji,jj,jk) = MIN( pe3w(ji,jj,jk), pe3w(ji,jj+1,jk) ) - pe3f (ji,jj,jk) = pe3v(ji,jj,jk) - END_3D - CALL lbc_lnk( 'usrdef_zgr', pe3v , 'V', 1._wp ) ; CALL lbc_lnk( 'usrdef_zgr', pe3vw, 'V', 1._wp ) - CALL lbc_lnk( 'usrdef_zgr', pe3f , 'F', 1._wp ) - DO jk = 1, jpk - ! set to z-scale factor if zero (i.e. along closed boundaries) because of lbclnk - WHERE( pe3u (:,:,jk) == 0._wp ) pe3u (:,:,jk) = pe3t_1d(jk) - WHERE( pe3v (:,:,jk) == 0._wp ) pe3v (:,:,jk) = pe3t_1d(jk) - WHERE( pe3f (:,:,jk) == 0._wp ) pe3f (:,:,jk) = pe3t_1d(jk) - WHERE( pe3uw(:,:,jk) == 0._wp ) pe3uw(:,:,jk) = pe3w_1d(jk) - WHERE( pe3vw(:,:,jk) == 0._wp ) pe3vw(:,:,jk) = pe3w_1d(jk) - END DO - ! - ENDIF - ! - END SUBROUTINE usr_def_zgr - - - SUBROUTINE zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! 1D reference vertical coordinate - !!---------------------------------------------------------------------- - !! *** ROUTINE zgr_z1d *** - !! - !! ** Purpose : set the depth of model levels and the resulting - !! vertical scale factors. - !! - !! ** Method : 1D z-coordinate system (use in all type of coordinate) - !! The depth of model levels is set from dep(k), an analytical function: - !! w-level: depw_1d = dep(k) - !! t-level: dept_1d = dep(k+0.5) - !! The scale factors are the discrete derivative of the depth: - !! e3w_1d(jk) = dk[ dept_1d ] - !! e3t_1d(jk) = dk[ depw_1d ] - !! - !! === Here constant vertical resolution === - !! - !! ** Action : - pdept_1d, pdepw_1d : depth of T- and W-point (m) - !! - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) - !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(:), INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] - REAL(wp), DIMENSION(:), INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] - ! - INTEGER :: jk ! dummy loop indices - REAL(wp) :: zt, zw ! local scalar - !!---------------------------------------------------------------------- - ! - IF(lwp) THEN ! Parameter print - WRITE(numout,*) - WRITE(numout,*) ' zgr_z1d : Reference vertical z-coordinates: uniform dz = ', rn_e3 - WRITE(numout,*) ' ~~~~~~~' - ENDIF - ! - ! Reference z-coordinate (depth - scale factor at T- and W-points) ! Madec & Imbard 1996 function - ! ---------------------- - DO jk = 1, jpk - zw = REAL( jk , wp ) - zt = REAL( jk , wp ) + 0.5_wp - pdepw_1d(jk) = rn_e3 * REAL( jk-1 , wp ) - pdept_1d(jk) = rn_e3 * ( REAL( jk-1 , wp ) + 0.5_wp ) - pe3w_1d (jk) = rn_e3 - pe3t_1d (jk) = rn_e3 - END DO - ! - IF(lwp) THEN ! control print - WRITE(numout,*) - WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:' - WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) - WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk ) - ENDIF - ! - END SUBROUTINE zgr_z1d - - !!====================================================================== -END MODULE usrdef_zgr diff --git a/tests/ISOMIP/cpp_ISOMIP.fcm b/tests/ISOMIP/cpp_ISOMIP.fcm deleted file mode 100644 index 4055ae28435f2ceea81e07f39f5f06ecbb0e2103..0000000000000000000000000000000000000000 --- a/tests/ISOMIP/cpp_ISOMIP.fcm +++ /dev/null @@ -1 +0,0 @@ - bld::tool::fppkeys key_xios diff --git a/tests/STATION_ASF/MY_SRC/stpctl.F90 b/tests/STATION_ASF/MY_SRC/stpctl.F90 index fd5a9214640c32238ce2e37a0498ff5554cfb230..a889111ad9355de67aa780cfb4a17871ea9159d5 100644 --- a/tests/STATION_ASF/MY_SRC/stpctl.F90 +++ b/tests/STATION_ASF/MY_SRC/stpctl.F90 @@ -74,8 +74,8 @@ CONTAINS IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid ! ll_wrtstp = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) - ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1 - ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm + ll_colruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. jpnij > 1 + ll_wrtruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. lwm ! IF( kt == nit000 ) THEN ! @@ -121,8 +121,8 @@ CONTAINS ! ll_0oce = .NOT. ANY( llmsk(:,:) ) ! no ocean point in the inner domain? ! - zmax(1) = MAXVAL( taum(:,:) , mask = llmsk ) ! max wind stress module - zmax(2) = MAXVAL( ABS( qns(:,:) ), mask = llmsk ) ! max non-solar heat flux + zmax(1) = MAXVAL( taum(:,:) , mask = llmsk(A2D(0)) ) ! max wind stress module + zmax(2) = MAXVAL( ABS( qns(:,:) ), mask = llmsk(A2D(0)) ) ! max non-solar heat flux zmax(3) = MAXVAL( ABS( emp(:,:) ), mask = llmsk ) ! max E-P zmax(jpvar+1) = REAL( nstop, wp ) ! stop indicator ! diff --git a/tests/SWG/MY_SRC/usrdef_sbc.F90 b/tests/SWG/MY_SRC/usrdef_sbc.F90 index 66ea77ad2ea3d1a8fc6f939af2f1336c644b7032..6283b4a579bbd5f9d238646aaf3ba6b8cd72e2fe 100644 --- a/tests/SWG/MY_SRC/usrdef_sbc.F90 +++ b/tests/SWG/MY_SRC/usrdef_sbc.F90 @@ -86,6 +86,7 @@ CONTAINS ztauu = REAL( rn_tau, wp ) * COS( rn_theta * rad ) ! N.m-2 ztauv = - REAL( rn_tau, wp ) * SIN( rn_theta * rad ) ! N.m-2 + zcoef = 1. / ( zrhoa * zcdrag ) DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! length of the domain : 2000km x 2000km utau(ji,jj) = - ztauu * COS( rpi * gphit(ji,jj) / 2000000._wp) @@ -93,10 +94,9 @@ CONTAINS END_2D ! module of wind stress and wind speed at T-point - zcoef = 1. / ( zrhoa * zcdrag ) - DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + DO_2D( 0, 0, 0, 0 ) zmod = SQRT( utau(ji,jj) * utau(ji,jj) + vtau(ji,jj) * vtau(ji,jj) ) - taum(ji,jj) = zmod + taum(ji,jj) = zmod wndm(ji,jj) = SQRT( zmod * zcoef ) END_2D ! diff --git a/tools/MISCELLANEOUS/chk_jijj_in_doloops.sh b/tools/MISCELLANEOUS/chk_jijj_in_doloops.sh new file mode 100755 index 0000000000000000000000000000000000000000..2664643b2eb7ef59a8fc836a1b1e7390dc1bd016 --- /dev/null +++ b/tools/MISCELLANEOUS/chk_jijj_in_doloops.sh @@ -0,0 +1,55 @@ +#!/bin/bash +# +# check if a do loop, starting with DO_2D, DO_3D ou DO ji=, contains (:,: +# that most probably should be (ji,jj +# +set -u + +for ff in $( find src -name "*90" ) */*/MY_SRC/*90 +do + + for ll1 in $( grep -n DO_2D $ff | sed -s "s/:.*//" ) + do + nb=$( sed -n ${ll1},/END_2D/p $ff | sed -e "s/\!.*//" | grep -c "( *: *, *:" ) + if [ $nb -ne 0 ] + then + echo "----------------------------------------------" + echo + echo "error in DO_2D: $ff $nb" + sed -n ${ll1},/END_2D/p $ff + echo + fi + done + + for ll1 in $( grep -n DO_3D $ff | sed -s "s/:.*//" ) + do + nb=$( sed -n ${ll1},/END_3D/p $ff | sed -e "s/\!.*//" | grep -c "( *: *, *:" ) + if [ $nb -ne 0 ] + then + echo "----------------------------------------------" + echo + echo "error in DO_3D: $ff $nb" + sed -n ${ll1},/END_3D/p $ff + echo + fi + done + + for ll1 in $( grep -in "DO *ji *=" $ff | sed -s "s/:.*//" ) + do + nb=$( sed -n ${ll1},/"[eE][nN][dD] *[dD][oO]"/p $ff | sed -e "s/\!.*//" | grep -c "( *: *, *:" ) + if [ $nb -ne 0 ] + then + echo "----------------------------------------------" + echo + echo "error in END DO: $ff $nb" + sed -n ${ll1},/"[eE][nN][dD] *[dD][oO]"/p $ff + echo + fi + done + +done + + + + +