diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7ad78049f3..e5af9feb36 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -116,8 +116,8 @@ run: - time tar zxf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - - echo "make -f MRS/Makefile.tests all -B" > job.sh - - msub -l partition=c4,nodes=29,walltime=00:31:00,qos=norm -q debug -S /bin/tcsh -j oe -A gfdl_o -z -o log.$CI_PIPELINE_ID -N mom6_regression -K job.sh + - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all -B') > job.sh + - sbatch --clusters=c3,c4 --nodes=29 --time=0:34:00 --account=gfdl_o --qos=debug --job-name=mom6_regressions --output=log.$CI_PIPELINE_ID --wait job.sh - cat log.$CI_PIPELINE_ID - test -f restart_results_gnu.tar.gz - time tar zvcf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz *.tar.gz diff --git a/.travis.yml b/.travis.yml index 5c5c31a6a4..1d200d1899 100644 --- a/.travis.yml +++ b/.travis.yml @@ -49,7 +49,7 @@ jobs: - stage: check and compile env: JOB="Code style compliance" script: - - ./.testing/trailer.py -e TEOS10 src config_src + - ./.testing/trailer.py -e TEOS10 -l 120 src config_src - stage: check and compile env: JOB="Doxygen" script: diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 09d7da3119..5112a0b64b 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -1177,12 +1177,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) default=".") CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & @@ -1190,64 +1190,64 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & "The latent heat of fusion.", units="J/kg", default=hlv) call get_param(param_file, mdl, "MAX_P_SURF", CS%max_p_surf, & - "The maximum surface pressure that can be exerted by the \n"//& - "atmosphere and floating sea-ice or ice shelves. This is \n"//& - "needed because the FMS coupling structure does not \n"//& - "limit the water that can be frozen out of the ocean and \n"//& - "the ice-ocean heat fluxes are treated explicitly. No \n"//& + "The maximum surface pressure that can be exerted by the "//& + "atmosphere and floating sea-ice or ice shelves. This is "//& + "needed because the FMS coupling structure does not "//& + "limit the water that can be frozen out of the ocean and "//& + "the ice-ocean heat fluxes are treated explicitly. No "//& "limit is applied if a negative value is used.", units="Pa", & default=-1.0) call get_param(param_file, mdl, "RESTORE_SALINITY", CS%restore_salt, & - "If true, the coupled driver will add a globally-balanced \n"//& - "fresh-water flux that drives sea-surface salinity \n"//& + "If true, the coupled driver will add a globally-balanced "//& + "fresh-water flux that drives sea-surface salinity "//& "toward specified values.", default=.false.) call get_param(param_file, mdl, "RESTORE_TEMPERATURE", CS%restore_temp, & - "If true, the coupled driver will add a \n"//& - "heat flux that drives sea-surface temperauture \n"//& + "If true, the coupled driver will add a "//& + "heat flux that drives sea-surface temperature "//& "toward specified values.", default=.false.) call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_TO_ZERO", & CS%adjust_net_srestore_to_zero, & - "If true, adjusts the salinity restoring seen to zero\n"//& + "If true, adjusts the salinity restoring seen to zero "//& "whether restoring is via a salt flux or virtual precip.",& default=CS%restore_salt) call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_BY_SCALING", & CS%adjust_net_srestore_by_scaling, & - "If true, adjustments to salt restoring to achieve zero net are\n"//& + "If true, adjustments to salt restoring to achieve zero net are "//& "made by scaling values without moving the zero contour.",& default=.false.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_TO_ZERO", & CS%adjust_net_fresh_water_to_zero, & - "If true, adjusts the net fresh-water forcing seen \n"//& + "If true, adjusts the net fresh-water forcing seen "//& "by the ocean (including restoring) to zero.", default=.false.) if (CS%adjust_net_fresh_water_to_zero) & call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & - "If true, use the wrong sign for the adjustment to\n"//& + "If true, use the wrong sign for the adjustment to "//& "the net fresh-water.", default=.true.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & - "If true, adjustments to net fresh water to achieve zero net are\n"//& + "If true, adjustments to net fresh water to achieve zero net are "//& "made by scaling values without moving the zero contour.",& default=.false.) call get_param(param_file, mdl, "ICE_SALT_CONCENTRATION", & CS%ice_salt_concentration, & - "The assumed sea-ice salinity needed to reverse engineer the \n"//& + "The assumed sea-ice salinity needed to reverse engineer the "//& "melt flux (or ice-ocean fresh-water flux).", & units="kg/kg", default=0.005) call get_param(param_file, mdl, "USE_LIMITED_PATM_SSH", CS%use_limited_P_SSH, & - "If true, return the sea surface height with the \n"//& - "correction for the atmospheric (and sea-ice) pressure \n"//& - "limited by max_p_surf instead of the full atmospheric \n"//& + "If true, return the sea surface height with the "//& + "correction for the atmospheric (and sea-ice) pressure "//& + "limited by max_p_surf instead of the full atmospheric "//& "pressure.", default=.true.) call get_param(param_file, mdl, "APPROX_NET_MASS_SRC", CS%approx_net_mass_src, & - "If true, use the net mass sources from the ice-ocean \n"//& - "boundary type without any further adjustments to drive \n"//& - "the ocean dynamics. The actual net mass source may differ \n"//& + "If true, use the net mass sources from the ice-ocean "//& + "boundary type without any further adjustments to drive "//& + "the ocean dynamics. The actual net mass source may differ "//& "due to internal corrections.", default=.false.) call get_param(param_file, mdl, "WIND_STAGGER", stagger, & - "A case-insensitive character string to indicate the \n"//& - "staggering of the input wind stress field. Valid \n"//& + "A case-insensitive character string to indicate the "//& + "staggering of the input wind stress field. Valid "//& "values are 'A', 'B', or 'C'.", default="C") if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID elseif (uppercase(stagger(1:1)) == 'B') then ; CS%wind_stagger = BGRID_NE @@ -1255,14 +1255,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) else ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & trim(stagger)//" is invalid.") ; endif call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & - "A factor multiplying the wind-stress given to the ocean by the\n"//& - "coupler. This is used for testing and should be =1.0 for any\n"//& + "A factor multiplying the wind-stress given to the ocean by the "//& + "coupler. This is used for testing and should be =1.0 for any "//& "production runs.", default=1.0) if (CS%restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & @@ -1276,19 +1276,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) CS%Flux_const = CS%Flux_const / 86400.0 call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & - "If true, the restoring of salinity is applied as a salt \n"//& + "If true, the restoring of salinity is applied as a salt "//& "flux instead of as a freshwater flux.", default=.false.) call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & "The maximum salinity difference used in restoring terms.", & units="PSU or g kg-1", default=999.0) call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & CS%mask_srestore_under_ice, & - "If true, disables SSS restoring under sea-ice based on a frazil\n"//& + "If true, disables SSS restoring under sea-ice based on a frazil "//& "criteria (SST<=Tf). Only used when RESTORE_SALINITY is True.", & default=.false.) call get_param(param_file, mdl, "MASK_SRESTORE_MARGINAL_SEAS", & CS%mask_srestore_marginal_seas, & - "If true, disable SSS restoring in marginal seas. Only used when\n"//& + "If true, disable SSS restoring in marginal seas. Only used when "//& "RESTORE_SALINITY is True.", default=.false.) call get_param(param_file, mdl, "BASIN_FILE", basin_file, & "A file in which to find the basin masks, in variable 'basin'.", & @@ -1303,14 +1303,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) enddo ; enddo endif call get_param(param_file, mdl, "MASK_SRESTORE", CS%mask_srestore, & - "If true, read a file (salt_restore_mask) containing \n"//& + "If true, read a file (salt_restore_mask) containing "//& "a mask for SSS restoring.", default=.false.) endif if (CS%restore_temp) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & @@ -1327,7 +1327,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "The maximum sst difference used in restoring terms.", & units="degC ", default=999.0) call get_param(param_file, mdl, "MASK_TRESTORE", CS%mask_trestore, & - "If true, read a file (temp_restore_mask) containing \n"//& + "If true, read a file (temp_restore_mask) containing "//& "a mask for SST restoring.", default=.false.) endif @@ -1340,11 +1340,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "The drag coefficient that applies to the tides.", & units="nondim", default=1.0e-4) call get_param(param_file, mdl, "READ_TIDEAMP", CS%read_TIDEAMP, & - "If true, read a file (given by TIDEAMP_FILE) containing \n"//& + "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) if (CS%read_TIDEAMP) then call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & - "The path to the file containing the spatially varying \n"//& + "The path to the file containing the spatially varying "//& "tidal amplitudes with INT_TIDE_DISSIPATION.", & default="tideamp.nc") CS%utide=0.0 @@ -1379,14 +1379,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) ! constant. call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from \n"//& + "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", units="Pa", & default=0.02) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in \n"//& + "The file in which the wind gustiness is found in "//& "variable gustiness.") call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) @@ -1396,31 +1396,31 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & - "If true, sea-ice is rigid enough to exert a \n"//& + "If true, sea-ice is rigid enough to exert a "//& "nonhydrostatic pressure that resist vertical motion.", & default=.false.) if (CS%rigid_sea_ice) then call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & - "A typical density of sea ice, used with the kinematic \n"//& + "A typical density of sea ice, used with the kinematic "//& "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & default=900.0) call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & - "The kinematic viscosity of sufficiently thick sea ice \n"//& + "The kinematic viscosity of sufficiently thick sea ice "//& "for use in calculating the rigidity of sea ice.", & units="m2 s-1", default=1.0e9) call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & - "The mass of sea-ice per unit area at which the sea-ice \n"//& + "The mass of sea-ice per unit area at which the sea-ice "//& "starts to exhibit rigidity", units="kg m-2", default=1000.0) endif call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & - "If true, makes available diagnostics of fluxes from icebergs\n"//& + "If true, makes available diagnostics of fluxes from icebergs "//& "as seen by MOM6.", default=.false.) call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles, & use_berg_fluxes=iceberg_flux_diags) call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & - "If true, allows flux adjustments to specified via the \n"//& + "If true, allows flux adjustments to specified via the "//& "data_table using the component name 'OCN'.", default=.false.) call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) diff --git a/config_src/coupled_driver/coupler_util.F90 b/config_src/coupled_driver/coupler_util.F90 deleted file mode 100644 index 2c72c56cce..0000000000 --- a/config_src/coupled_driver/coupler_util.F90 +++ /dev/null @@ -1,137 +0,0 @@ -!> Provides a couple of interfaces to allow more transparent and -!! robust extraction of the various fields in the coupler types. -module coupler_util - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use coupler_types_mod, only : coupler_2d_bc_type, ind_flux, ind_alpha -use coupler_types_mod, only : ind_csurf - -implicit none ; private - -public :: extract_coupler_values, set_coupler_values -public :: ind_flux, ind_alpha, ind_csurf - -contains - -!> Extract an array of values in a coupler bc type -subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, & - is, ie, js, je, conversion) - type(coupler_2d_bc_type), intent(in) :: BC_struc !< The type from which the data is being extracted. - integer, intent(in) :: BC_index !< The boundary condition number being extracted. - integer, intent(in) :: BC_element !< The element of the boundary condition being extracted. - real, dimension(:,:), intent(out) :: array_out !< The array being filled with the input values. - integer, optional, intent(in) :: is !< Start i-index - integer, optional, intent(in) :: ie !< End i-index - integer, optional, intent(in) :: js !< Start j-index - integer, optional, intent(in) :: je !< End j-index - real, optional, intent(in) :: conversion !< A number that every element is multiplied by, to - !! permit sign convention or unit conversion. - ! Local variables - real, pointer, dimension(:,:) :: Array_in - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_in => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_out,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_out,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_out,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_out,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_in,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - if (size(Array_in,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - i_offset = lbound(Array_in,1) - is0 - j_offset = lbound(Array_in,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - array_out(i,j) = conv * Array_in(i+i_offset,j+j_offset) - enddo ; enddo - -end subroutine extract_coupler_values - -!> Set an array of values in a coupler bc type -subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, & - is, ie, js, je, conversion) - real, dimension(:,:), intent(in) :: array_in !< The array containing the values to load into the BC. - type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type from which the data is being extracted. - integer, intent(in) :: BC_index !< The boundary condition number being extracted. - integer, intent(in) :: BC_element !< The element of the boundary condition being extracted. - !! This could be ind_csurf, ind_alpha, ind_flux or ind_deposition. - integer, optional, intent(in) :: is !< Start i-index - integer, optional, intent(in) :: ie !< End i-index - integer, optional, intent(in) :: js !< Start j-index - integer, optional, intent(in) :: je !< End j-index - real, optional, intent(in) :: conversion !< A number that every element is multiplied by, to - !! permit sign convention or unit conversion. - ! Local variables - real, pointer, dimension(:,:) :: Array_out - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_out => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_in,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_in,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_in,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_in,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_out,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - if (size(Array_out,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - i_offset = lbound(Array_out,1) - is0 - j_offset = lbound(Array_out,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - Array_out(i+i_offset,j+j_offset) = conv * array_in(i,j) - enddo ; enddo - -end subroutine set_coupler_values - -end module coupler_util diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index b62f479354..f9b84a97e1 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -278,41 +278,41 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SINGLE_STEPPING_CALL", OS%single_step_call, & - "If true, advance the state of MOM with a single step \n"//& - "including both dynamics and thermodynamics. If false, \n"//& + "If true, advance the state of MOM with a single step "//& + "including both dynamics and thermodynamics. If false, "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mdl, "DT", OS%dt, & - "The (baroclinic) dynamics time step. The time-step that \n"//& - "is actually used will be an integer fraction of the \n"//& + "The (baroclinic) dynamics time step. The time-step that "//& + "is actually used will be an integer fraction of the "//& "forcing time-step.", units="s", fail_if_missing=.true.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & - "The thermodynamic and tracer advection time step. \n"//& - "Ideally DT_THERM should be an integer multiple of DT \n"//& - "and less than the forcing or coupling time-step, unless \n"//& - "THERMO_SPANS_COUPLING is true, in which case DT_THERM \n"//& - "can be an integer multiple of the coupling timestep. By \n"//& + "The thermodynamic and tracer advection time step. "//& + "Ideally DT_THERM should be an integer multiple of DT "//& + "and less than the forcing or coupling time-step, unless "//& + "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& + "can be an integer multiple of the coupling timestep. By "//& "default DT_THERM is set to DT.", units="s", default=OS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & - "If true, the MOM will take thermodynamic and tracer \n"//& - "timesteps that can be longer than the coupling timestep. \n"//& - "The actual thermodynamic timestep that is used in this \n"//& - "case is the largest integer multiple of the coupling \n"//& + "If true, the MOM will take thermodynamic and tracer "//& + "timesteps that can be longer than the coupling timestep. "//& + "The actual thermodynamic timestep that is used in this "//& + "case is the largest integer multiple of the coupling "//& "timestep that is less than or equal to DT_THERM.", default=.false.) call get_param(param_file, mdl, "DIABATIC_FIRST", OS%diabatic_first, & - "If true, apply diabatic and thermodynamic processes, \n"//& - "including buoyancy forcing and mass gain or loss, \n"//& + "If true, apply diabatic and thermodynamic processes, "//& + "including buoyancy forcing and mass gain or loss, "//& "before stepping the dynamics forward.", default=.false.) call get_param(param_file, mdl, "RESTART_CONTROL", OS%Restart_control, & - "An integer whose bits encode which restart files are \n"//& - "written. Add 2 (bit 1) for a time-stamped file, and odd \n"//& - "(bit 0) for a non-time-stamped file. A restart file \n"//& - "will be saved at the end of the run segment for any \n"//& + "An integer whose bits encode which restart files are "//& + "written. Add 2 (bit 1) for a time-stamped file, and odd "//& + "(bit 0) for a non-time-stamped file. A restart file "//& + "will be saved at the end of the run segment for any "//& "non-negative value.", default=1) call get_param(param_file, mdl, "OCEAN_SURFACE_STAGGER", stagger, & - "A case-insensitive character string to indicate the \n"//& - "staggering of the surface velocity field that is \n"//& - "returned to the coupler. Valid values include \n"//& + "A case-insensitive character string to indicate the "//& + "staggering of the surface velocity field that is "//& + "returned to the coupler. Valid values include "//& "'A', 'B', or 'C'.", default="C") if (uppercase(stagger(1:1)) == 'A') then ; Ocean_sfc%stagger = AGRID elseif (uppercase(stagger(1:1)) == 'B') then ; Ocean_sfc%stagger = BGRID_NE @@ -321,9 +321,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) trim(stagger)//" is invalid.") ; endif call get_param(param_file, mdl, "RHO_0", Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "G_EARTH", G_Earth, & @@ -341,9 +341,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) ! Consider using a run-time flag to determine whether to do the diagnostic ! vertical integrals, since the related 3-d sums are not negligible in cost. call get_param(param_file, mdl, "HFREEZE", HFrz, & - "If HFREEZE > 0, melt potential will be computed. The actual depth \n"//& - "over which melt potential is computed will be min(HFREEZE, OBLD), \n"//& - "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), \n"//& + "If HFREEZE > 0, melt potential will be computed. The actual depth "//& + "over which melt potential is computed will be min(HFREEZE, OBLD), "//& + "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& "melt potential will not be computed.", units="m", default=-1.0, do_not_log=.true.) if (HFrz .gt. 0.0) then diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index aec37b2a4a..77099b2595 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -976,7 +976,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & "The directory in which all input files are found.", & @@ -984,33 +984,33 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is \n"//& - "true. This assumes that KD = KDML = 0.0 and that \n"//& - "there is no buoyancy forcing, but makes the model \n"//& + "There are no diapycnal mass fluxes if ADIABATIC is "//& + "true. This assumes that KD = KDML = 0.0 and that "//& + "there is no buoyancy forcing, but makes the model "//& "faster by eliminating subroutine calls.", default=.false.) call get_param(param_file, mdl, "VARIABLE_WINDS", CS%variable_winds, & "If true, the winds vary in time after the initialization.", & default=.true.) call get_param(param_file, mdl, "VARIABLE_BUOYFORCE", CS%variable_buoyforce, & - "If true, the buoyancy forcing varies in time after the \n"//& + "If true, the buoyancy forcing varies in time after the "//& "initialization of the model.", default=.true.) call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & - "The character string that indicates how buoyancy forcing \n"//& - "is specified. Valid options include (file), (zero), \n"//& + "The character string that indicates how buoyancy forcing "//& + "is specified. Valid options include (file), (zero), "//& "(linear), (USER), and (NONE).", fail_if_missing=.true.) if (trim(CS%buoy_config) == "file") then call get_param(param_file, mdl, "LONGWAVEDOWN_FILE", CS%longwavedown_file, & - "The file with the downward longwave heat flux, in \n"//& + "The file with the downward longwave heat flux, in "//& "variable lwdn_sfc.", fail_if_missing=.true.) call get_param(param_file, mdl, "LONGWAVEUP_FILE", CS%longwaveup_file, & - "The file with the upward longwave heat flux, in \n"//& + "The file with the upward longwave heat flux, in "//& "variable lwup_sfc.", fail_if_missing=.true.) call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & - "The file with the evaporative moisture flux, in \n"//& + "The file with the evaporative moisture flux, in "//& "variable evap.", fail_if_missing=.true.) call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & - "The file with the sensible heat flux, in \n"//& + "The file with the sensible heat flux, in "//& "variable shflx.", fail_if_missing=.true.) call get_param(param_file, mdl, "SHORTWAVEUP_FILE", CS%shortwaveup_file, & "The file with the upward shortwave heat flux.", & @@ -1019,28 +1019,28 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The file with the downward shortwave heat flux.", & fail_if_missing=.true.) call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & - "The file with the downward frozen precip flux, in \n"//& + "The file with the downward frozen precip flux, in "//& "variable snow.", fail_if_missing=.true.) call get_param(param_file, mdl, "PRECIP_FILE", CS%precip_file, & - "The file with the downward total precip flux, in \n"//& + "The file with the downward total precip flux, in "//& "variable precip.", fail_if_missing=.true.) call get_param(param_file, mdl, "FRESHDISCHARGE_FILE", CS%freshdischarge_file, & - "The file with the fresh and frozen runoff/calving fluxes, \n"//& + "The file with the fresh and frozen runoff/calving fluxes, "//& "invariables disch_w and disch_s.", fail_if_missing=.true.) call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in \n"//& + "The file with the SST toward which to restore in "//& "variable TEMP.", fail_if_missing=.true.) call get_param(param_file, mdl, "SALINITYRESTORE_FILE", CS%salinityrestore_file, & - "The file with the surface salinity toward which to \n"//& + "The file with the surface salinity toward which to "//& "restore in variable SALT.", fail_if_missing=.true.) endif call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & - "The character string that indicates how wind forcing \n"//& - "is specified. Valid options include (file), (2gyre), \n"//& + "The character string that indicates how wind forcing "//& + "is specified. Valid options include (file), (2gyre), "//& "(1gyre), (gyres), (zero), and (USER).", fail_if_missing=.true.) if (trim(CS%wind_config) == "file") then call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & - "The file in which the wind stresses are found in \n"//& + "The file in which the wind stresses are found in "//& "variables STRESS_X and STRESS_Y.", fail_if_missing=.true.) call get_param(param_file, mdl, "WINDSTRESS_X_VAR",CS%stress_x_var, & "The name of the x-wind stress variable in WIND_FILE.", & @@ -1049,7 +1049,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The name of the y-wind stress variable in WIND_FILE.", & default="STRESS_Y") call get_param(param_file, mdl, "WINDSTRESS_STAGGER",CS%wind_stagger, & - "A character indicating how the wind stress components \n"//& + "A character indicating how the wind stress components "//& "are staggered in WIND_FILE. This may be A or C for now.", & default="A") call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & @@ -1058,66 +1058,66 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C endif if (trim(CS%wind_config) == "gyres") then call get_param(param_file, mdl, "TAUX_CONST", CS%gyres_taux_const, & - "With the gyres wind_config, the constant offset in the \n"//& - "zonal wind stress profile: \n"//& + "With the gyres wind_config, the constant offset in the "//& + "zonal wind stress profile: "//& " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="Pa", default=0.0) call get_param(param_file, mdl, "TAUX_SIN_AMP",CS%gyres_taux_sin_amp, & - "With the gyres wind_config, the sine amplitude in the \n"//& - "zonal wind stress profile: \n"//& + "With the gyres wind_config, the sine amplitude in the "//& + "zonal wind stress profile: "//& " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="Pa", default=0.0) call get_param(param_file, mdl, "TAUX_COS_AMP",CS%gyres_taux_cos_amp, & - "With the gyres wind_config, the cosine amplitude in \n"//& - "the zonal wind stress profile: \n"//& + "With the gyres wind_config, the cosine amplitude in "//& + "the zonal wind stress profile: "//& " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="Pa", default=0.0) call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & - "With the gyres wind_config, the number of gyres in \n"//& - "the zonal wind stress profile: \n"//& + "With the gyres wind_config, the number of gyres in "//& + "the zonal wind stress profile: "//& " n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="nondim", default=0.0) endif call get_param(param_file, mdl, "SOUTHLAT", CS%south_lat, & - "The southern latitude of the domain or the equivalent \n"//& + "The southern latitude of the domain or the equivalent "//& "starting value for the y-axis.", units=axis_units, default=0.) call get_param(param_file, mdl, "LENLAT", CS%len_lat, & "The latitudinal or y-direction length of the domain.", & units=axis_units, fail_if_missing=.true.) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 if (trim(CS%buoy_config) == "linear") then call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & - "With buoy_config linear, the sea surface temperature \n"//& - "at the northern end of the domain toward which to \n"//& + "With buoy_config linear, the sea surface temperature "//& + "at the northern end of the domain toward which to "//& "to restore.", units="deg C", default=0.0) call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & - "With buoy_config linear, the sea surface temperature \n"//& - "at the southern end of the domain toward which to \n"//& + "With buoy_config linear, the sea surface temperature "//& + "at the southern end of the domain toward which to "//& "to restore.", units="deg C", default=0.0) call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & - "With buoy_config linear, the sea surface salinity \n"//& - "at the northern end of the domain toward which to \n"//& + "With buoy_config linear, the sea surface salinity "//& + "at the northern end of the domain toward which to "//& "to restore.", units="PSU", default=35.0) call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & - "With buoy_config linear, the sea surface salinity \n"//& - "at the southern end of the domain toward which to \n"//& + "With buoy_config linear, the sea surface salinity "//& + "at the southern end of the domain toward which to "//& "to restore.", units="PSU", default=35.0) endif endif @@ -1129,11 +1129,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The background gustiness in the winds.", units="Pa", & default=0.02) call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from \n"//& + "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in \n"//& + "The file in which the wind gustiness is found in "//& "variable gustiness.", fail_if_missing=.true.) call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) ; CS%gust(:,:) = 0.0 filename = trim(CS%inputdir) // trim(gust_file) diff --git a/config_src/ice_solo_driver/coupler_types.F90 b/config_src/ice_solo_driver/coupler_types.F90 deleted file mode 100644 index 99a74e085c..0000000000 --- a/config_src/ice_solo_driver/coupler_types.F90 +++ /dev/null @@ -1,3294 +0,0 @@ -module coupler_types_mod - -! This file is part of MOM6. See LICENSE.md for the license. - -! This module contains the coupler-type declarations and methods for use in -! ocean-only configurations of MOM6. It is intended that the version of -! coupler_types_mod that is avialable from FMS will conform to this version with -! the FMS city release after warsaw. - -use fms_io_mod, only: restart_file_type, register_restart_field -use fms_io_mod, only: query_initialized, restore_state -use time_manager_mod, only: time_type -use diag_manager_mod, only: register_diag_field, send_data -use data_override_mod, only: data_override -use mpp_domains_mod, only: domain2D, mpp_redistribute -use mpp_mod, only: stdout, mpp_error, FATAL, mpp_chksum - -implicit none ; private - -public coupler_type_copy, coupler_type_spawn, coupler_type_set_diags -public coupler_type_write_chksums, coupler_type_send_data, coupler_type_data_override -public coupler_type_register_restarts, coupler_type_restore_state -public coupler_type_increment_data, coupler_type_rescale_data -public coupler_type_copy_data, coupler_type_redistribute_data -public coupler_type_destructor, coupler_type_initialized -public coupler_type_extract_data, coupler_type_set_data - -public coupler_type_copy_1d_2d -public coupler_type_copy_1d_3d - -! -! 3-d fields -! -type, public :: coupler_3d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_3d_values_type - -type, public :: coupler_3d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_3d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_3d_field_type - -type, public :: coupler_3d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type - integer :: ks, ke !< The k-direction index ranges for this type -end type coupler_3d_bc_type - -! -! 2-d fields -! -type, public :: coupler_2d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_2d_values_type - -type, public :: coupler_2d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_2d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_2d_field_type - -type, public :: coupler_2d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type -end type coupler_2d_bc_type - -! -! 1-d fields -! -type, public :: coupler_1d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, dimension(:) :: values => NULL() !< The pointer to the array of values - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_1d_values_type - -type, public :: coupler_1d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_1d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_1d_field_type - -type, public :: coupler_1d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized -end type coupler_1d_bc_type - -!---------------------------------------------------------------------- -! The following public parameters can help in selecting the sub-elements of a -! coupler type. There are duplicate values because different boundary -! conditions have different sub-elements. -integer, parameter, public :: ind_pcair = 1 !< The index of the atmospheric concentration -integer, parameter, public :: ind_u10 = 2 !< The index of the 10 m wind speed -integer, parameter, public :: ind_psurf = 3 !< The index of the surface atmospheric pressure -integer, parameter, public :: ind_alpha = 1 !< The index of the solubility array for a tracer -integer, parameter, public :: ind_csurf = 2 !< The index of the ocean surface concentration -integer, parameter, public :: ind_sc_no = 3 !< The index for the Schmidt number for a tracer flux -integer, parameter, public :: ind_flux = 1 !< The index for the tracer flux -integer, parameter, public :: ind_deltap= 2 !< The index for ocean-air gas partial pressure change -integer, parameter, public :: ind_kw = 3 !< The index for the piston velocity -integer, parameter, public :: ind_deposition = 1 !< The index for the atmospheric deposition flux -integer, parameter, public :: ind_runoff = 1 !< The index for a runoff flux - -!---------------------------------------------------------------------- -! Interface definitions for overloaded routines -!---------------------------------------------------------------------- - -!> This is the interface to spawn one coupler_bc_type into another and then -!! register diagnostics associated with the new type. -interface coupler_type_copy - module procedure coupler_type_copy_1d_2d, coupler_type_copy_1d_3d - module procedure coupler_type_copy_2d_2d, coupler_type_copy_2d_3d - module procedure coupler_type_copy_3d_2d, coupler_type_copy_3d_3d -end interface coupler_type_copy - -!> This is the interface to spawn one coupler_bc_type into another. -interface coupler_type_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d, CT_spawn_3d_2d - module procedure CT_spawn_1d_3d, CT_spawn_2d_3d, CT_spawn_3d_3d -end interface coupler_type_spawn - -!> This is the interface to copy the field data from one coupler_bc_type -!! to another of the same rank, size and decomposition. -interface coupler_type_copy_data - module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d -end interface coupler_type_copy_data - -!> This is the interface to redistribute the field data from one coupler_bc_type -!! to another of the same rank and global size, but a different decomposition. -interface coupler_type_redistribute_data - module procedure CT_redistribute_data_2d, CT_redistribute_data_3d -end interface coupler_type_redistribute_data - -!> This is the interface to rescale the field data in a coupler_bc_type. -interface coupler_type_rescale_data - module procedure CT_rescale_data_2d, CT_rescale_data_3d -end interface coupler_type_rescale_data - -!> This is the interface to increment the field data from one coupler_bc_type -!! with the data from another. Both must have the same horizontal size and -!! decomposition, but a 2d type may be incremented by a 2d or 3d type -interface coupler_type_increment_data - module procedure CT_increment_data_2d_2d, CT_increment_data_3d_3d, CT_increment_data_2d_3d -end interface coupler_type_increment_data - -!> This is the interface to extract a field in a coupler_bc_type into an array. -interface coupler_type_extract_data - module procedure CT_extract_data_2d, CT_extract_data_3d, CT_extract_data_3d_2d -end interface coupler_type_extract_data - -!> This is the interface to set a field in a coupler_bc_type from an array. -interface coupler_type_set_data - module procedure CT_set_data_2d, CT_set_data_3d, CT_set_data_2d_3d -end interface coupler_type_set_data - -!> This is the interface to set diagnostics for the arrays in a coupler_bc_type. -interface coupler_type_set_diags - module procedure CT_set_diags_2d, CT_set_diags_3d -end interface coupler_type_set_diags - -!> This is the interface to write out checksums for the elements of a coupler_bc_type. -interface coupler_type_write_chksums - module procedure CT_write_chksums_2d, CT_write_chksums_3d -end interface coupler_type_write_chksums - -!> This is the interface to write out diagnostics of the arrays in a coupler_bc_type. -interface coupler_type_send_data - module procedure CT_send_data_2d, CT_send_data_3d -end interface coupler_type_send_data - -!> This is the interface to override the values of the arrays in a coupler_bc_type. -interface coupler_type_data_override - module procedure CT_data_override_2d, CT_data_override_3d -end interface coupler_type_data_override - -!> This is the interface to register the fields in a coupler_bc_type to be saved -!! in restart files. -interface coupler_type_register_restarts - module procedure CT_register_restarts_2d, CT_register_restarts_3d - module procedure CT_register_restarts_to_file_2d, CT_register_restarts_to_file_3d -end interface coupler_type_register_restarts - -!> This is the interface to read in the fields in a coupler_bc_type that have -!! been saved in restart files. -interface coupler_type_restore_state - module procedure CT_restore_state_2d, CT_restore_state_3d -end interface coupler_type_restore_state - -!> This function interface indicates whether a coupler_bc_type has been initialized. -interface coupler_type_initialized - module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d -end interface coupler_type_initialized - -!> This is the interface to deallocate any data associated with a coupler_bc_type. -interface coupler_type_destructor - module procedure CT_destructor_1d, CT_destructor_2d, CT_destructor_3d -end interface coupler_type_destructor - -contains - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 1-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_1d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_1d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_1d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 1-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_1d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_1d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_1d_3d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 2-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_2d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_2d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_2d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 2-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_2d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_2d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_2d_3d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 3-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_3d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_3d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_3d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 3-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_3d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_3d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_3d_3d - - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 1-D to 2-D version for generic coupler_type_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var_out, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) - - type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_1d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_1d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 1-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) - - type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in - !! a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_1d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_1d_3d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 2-D to 2-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) - - type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_2d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_2d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 2-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) - - type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in - !! a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_2d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_2d_3d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 3-D to 2-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) - - type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_3d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_3d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 3-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) - - type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in - !! a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_3d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_3d_3d - - -!> This subroutine does a direct copy of the data in all elements of one -!! coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: copy_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_2d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_2d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_2d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_2d - -!> This subroutine does a direct copy of the data in all elements of one -!! coupler_3d_bc_type into another. Both types must have the same array sizes. -subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is a k-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc ; k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_3d - -!> This subroutine does a direct copy of the data in all elements of a -!! coupler_2d_bc_type into a coupler_3d_bc_type. Both types must have the same -!! array sizes for their first two dimensions, while the extent of the 3rd dimension -!! that is being filled may be specified via optional arguments. -subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice, & - ind3_start, ind3_end) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd - !! index of the 3d type to fill in. - integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd - !! index of the 3d type to fill in. - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, ks, ke - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the output structure.") - endif - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var_in%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var_in%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var_in%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - ks = var%ks ; if (present(ind3_start)) ks = max(ks, ind3_start) - ke = var%ke ; if (present(ind3_end)) ke = max(ke, ind3_end) - do k=ks,ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_2d_3d - - -!> This subroutine redistributes the data in all elements of one coupler_2d_bc_type -!! into another, which may be on different processors with a different decomposition. -subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy (intent in) - type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure - type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) - type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure - logical, optional, intent(in) :: complete !< If true, complete the updates - - real, pointer, dimension(:,:) :: null_ptr2D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. ; if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 ; fc_out = 0 - if (do_in) then ; do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo ; enddo ; endif - if (fc_in == 0) do_in = .false. - if (do_out) then ; do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo ; enddo ; endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL, & - "Mismatch in num_bcs in CT_copy_data_2d.") - if (fc_in /= fc_out) call mpp_error(FATAL, & - "Mismatch in the total number of fields in CT_redistribute_data_2d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv. & - associated(var_out%bc(n)%field(m)%values) ) & - call mpp_error(FATAL, & - "Mismatch in which fields are associated in CT_redistribute_data_2d.") - - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_in) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, null_ptr2D, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_out) then - do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr2D, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo ; enddo - endif - -end subroutine CT_redistribute_data_2d - -!> This subroutine redistributes the data in all elements of one coupler_2d_bc_type -!! into another, which may be on different processors with a different decomposition. -subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy (intent in) - type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure - type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) - type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure - logical, optional, intent(in) :: complete !< If true, complete the updates - - real, pointer, dimension(:,:,:) :: null_ptr3D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. ; if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 ; fc_out = 0 - if (do_in) then ; do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo ; enddo ; endif - if (fc_in == 0) do_in = .false. - if (do_out) then ; do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo ; enddo ; endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL, & - "Mismatch in num_bcs in CT_copy_data_3d.") - if (fc_in /= fc_out) call mpp_error(FATAL, & - "Mismatch in the total number of fields in CT_redistribute_data_3d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv. & - associated(var_out%bc(n)%field(m)%values) ) & - call mpp_error(FATAL, & - "Mismatch in which fields are associated in CT_redistribute_data_3d.") - - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_in) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, null_ptr3D, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_out) then - do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr3D, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo ; enddo - endif - -end subroutine CT_redistribute_data_3d - - -!> This subroutine rescales the fields in the elements of a coupler_2d_bc_type -!! by multiplying by a factor scale. If scale is 0, this is a direct -!! assignment to 0, so that NaNs will not persist. -subroutine CT_rescale_data_2d(var, scale, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or - !! the full arrays if scale is 0. - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: do_bc - integer :: i, j, m, n, n1, n2, halo - - if (present(bc_index)) then - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.") - if (present(field_index)) then ; if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_2d: Excessive i-direction halo size.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_2d: Excessive j-direction halo size.") - endif - - do n = n1, n2 - - do_bc = .true. - if (do_bc .and. present(exclude_flux_type)) & - do_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (do_bc .and. present(only_flux_type)) & - do_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (do_bc .and. present(pass_through_ice)) & - do_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.do_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - if (scale == 0.0) then - if (present(halo_size)) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = 0.0 - enddo ; enddo - else - var%bc(n)%field(m)%values(:,:) = 0.0 - endif - else - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = scale * var%bc(n)%field(m)%values(i,j) - enddo ; enddo - endif - endif - enddo - enddo - -end subroutine CT_rescale_data_2d - -!> This subroutine rescales the fields in the elements of a coupler_3d_bc_type -!! by multiplying by a factor scale. If scale is 0, this is a direct -!! assignment to 0, so that NaNs will not persist. -subroutine CT_rescale_data_3d(var, scale, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or - !! the full arrays if scale is 0. - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: do_bc - integer :: i, j, k, m, n, n1, n2, halo - - if (present(bc_index)) then - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.") - if (present(field_index)) then ; if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_3d: Excessive i-direction halo size.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_3d: Excessive j-direction halo size.") - endif - - do n = n1, n2 - - do_bc = .true. - if (do_bc .and. present(exclude_flux_type)) & - do_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (do_bc .and. present(only_flux_type)) & - do_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (do_bc .and. present(pass_through_ice)) & - do_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.do_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - if (scale == 0.0) then - if (present(halo_size)) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = 0.0 - enddo ; enddo ; enddo - else - var%bc(n)%field(m)%values(:,:,:) = 0.0 - endif - else - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = scale * var%bc(n)%field(m)%values(i,j,k) - enddo ; enddo ; enddo - endif - endif - enddo - enddo - -end subroutine CT_rescale_data_3d - - -!> This subroutine does a direct increment of the data in all elements of one -!! coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this increment. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_2d_2d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_2d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_2d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = sc_prev * var%bc(n)%field(m)%values(i,j) + & - scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_2d_2d - - -!> This subroutine does a direct increment of the data in all elements of one -!! coupler_3d_bc_type into another. Both must have the same array sizes. -subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this increment. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_3d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is a k-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc ; k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = sc_prev * var%bc(n)%field(m)%values(i,j,k) + & - scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_3d_3d - -!> This subroutine does increments the data in the elements of a coupler_2d_bc_type -!! with the weighed average of the elements of a coupler_3d_bc_type. Both must have -!! the same horizontal array sizes and the normalized weight array must match the -!! array sizes of the coupler_3d_bc_type. -subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type - real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to - !! increment the 2d-data. There is no renormalization, - !! so if the weights do not sum to 1 in the 3rd dimension - !! there may be adverse consequences! - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this increment. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, k, m, n, n1, n2, halo - integer :: io1, jo1, iow, jow, kow ! Offsets to account for different index conventions. - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_2d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is a j-direction computional domain size mismatch.") - if ((1+var_in%ke-var_in%ks) /= size(weights,3)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is a k-direction size mismatch with the weights array.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive j-direction halo size for the output structure.") - - if ((1+var%iec-var%isc) == size(weights,1)) then - iow = 1 - var%isc - elseif ((1+var%ied-var%isd) == size(weights,1)) then - iow = 1 - var%isd - elseif ((1+var_in%ied-var_in%isd) == size(weights,1)) then - iow = 1 + (var_in%isc - var_in%isd) - var%isc - else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size "//& - "of a computational or data domain.") - endif - if ((1+var%jec-var%jsc) == size(weights,2)) then - jow = 1 - var%jsc - elseif ((1+var%jed-var%jsd) == size(weights,2)) then - jow = 1 - var%jsd - elseif ((1+var_in%jed-var_in%jsd) == size(weights,2)) then - jow = 1 + (var_in%jsc - var_in%jsd) - var%jsc - else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size "//& - "of a computational or data domain.") - endif - - io1 = var_in%isc - var%isc ; jo1 = var_in%jsc - var%jsc ; kow = 1 - var_in%ks - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var_in%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var_in%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var_in%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var_in%ks,var_in%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = sc_prev * var%bc(n)%field(m)%values(i,j) + & - (scale * weights(i+iow,j+jow,k+kow)) * var_in%bc(n)%field(m)%values(i+io1,j+io1,k) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_2d_3d - - -!> This subroutine extracts a single 2-d field from a coupler_2d_bc_type into -!! a two-dimensional array. -subroutine CT_extract_data_2d(var_in, bc_index, field_index, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j) - enddo ; enddo - -end subroutine CT_extract_data_2d - -!> This subroutine extracts a single k-level of a 3-d field from a coupler_3d_bc_type -!! into a two-dimensional array. -subroutine CT_extract_data_3d_2d(var_in, bc_index, field_index, k_in, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - integer, intent(in) :: k_in !< The k-index to extract - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_3d_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if ((k_in > var_in%ke) .or. (k_in < var_in%ks)) then - write (error_msg, *) trim(error_header), ' The extracted k-index of ', k_in, & - ' is outside of the valid range of ', var_in%ks, ' to ', var_in%ke - call mpp_error(FATAL, trim(error_msg)) - endif - - do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k_in) - enddo ; enddo - -end subroutine CT_extract_data_3d_2d - -!> This subroutine extracts a single 3-d field from a coupler_3d_bc_type into -!! a three-dimensional array. -subroutine CT_extract_data_3d(var_in, bc_index, field_index, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, dimension(1:,1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_3d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off, k_off - - if (bc_index <= 0) then - array_out(:,:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if (size(array_out,3) /= 1 + var_in%ke - var_in%ks) then - write (error_msg, *) trim(error_header), ' The target array with k-dimension size ', & - size(array_out,3), ' does not match the data of size ', & - (1 + var_in%ke - var_in%ks) - call mpp_error(FATAL, trim(error_msg)) - endif - k_off = 1 - var_in%ks - - do k=var_in%ks,var_in%ke ; do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off,k+k_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k) - enddo ; enddo ; enddo - -end subroutine CT_extract_data_3d - - -!> This subroutine sets a single 2-d field in a coupler_3d_bc_type from -!! a two-dimensional array. -subroutine CT_set_data_2d(array_in, bc_index, field_index, var, & - scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j) = scale * array_in(i+i_off,j+j_off) - enddo ; enddo - -end subroutine CT_set_data_2d - -!> This subroutine sets a one k-level of a single 3-d field in a -!! coupler_3d_bc_type from a two-dimensional array. -subroutine CT_set_data_2d_3d(array_in, bc_index, field_index, k_out, var, & - scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - integer, intent(in) :: k_out !< The k-index to set - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_3d_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - if ((k_out > var%ke) .or. (k_out < var%ks)) then - write (error_msg, *) trim(error_header), ' The seted k-index of ', k_out, & - ' is outside of the valid range of ', var%ks, ' to ', var%ke - call mpp_error(FATAL, trim(error_msg)) - endif - - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j,k_out) = scale * array_in(i+i_off,j+j_off) - enddo ; enddo - -end subroutine CT_set_data_2d_3d - -!> This subroutine sets a single 3-d field in a coupler_3d_bc_type from -!! a three-dimensional array. -subroutine CT_set_data_3d(array_in, bc_index, field_index, var, & - scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:,1:), intent(in) :: array_in !< The source array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_3d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off, k_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - if (size(array_in,3) /= 1 + var%ke - var%ks) then - write (error_msg, *) trim(error_header), ' The target array with k-dimension size ', & - size(array_in,3), ' does not match the data of size ', & - (1 + var%ke - var%ks) - call mpp_error(FATAL, trim(error_msg)) - endif - k_off = 1 - var%ks - - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j,k) = scale * array_in(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - -end subroutine CT_set_data_3d - - -!> This routine registers the diagnostics of a coupler_2d_bc_type. -subroutine CT_set_diags_2d(var, diag_name, axes, time) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 2) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - '(coupler_types_set_diags_3d): axes has less than 2 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name, & - var%bc(n)%field(m)%name, axes(1:2), Time, & - var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units ) - enddo - enddo - -end subroutine CT_set_diags_2d - -!> This routine registers the diagnostics of a coupler_3d_bc_type. -subroutine CT_set_diags_3d(var, diag_name, axes, time) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 3) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - '(coupler_types_set_diags_3d): axes has less than 3 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name, & - var%bc(n)%field(m)%name, axes(1:3), Time, & - var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units ) - enddo - enddo - -end subroutine CT_set_diags_3d - - -!> This subroutine writes out all diagnostics of elements of a coupler_2d_bc_type -subroutine CT_send_data_2d(var, Time) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_send_data_2d - -!> This subroutine writes out all diagnostics of elements of a coupler_2d_bc_type -subroutine CT_send_data_3d(var, Time) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_send_data_3d - - -!> This subroutine registers the fields in a coupler_2d_bc_type to be saved -!! in restart files specified in the field table. -subroutine CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m - - ocn_rest = .true. ; if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = register_restart_field(bc_rest_files(f), & - rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_2d - -!> This subroutine registers the fields in a coupler_2d_bc_type to be saved -!! in the specified restart file. -subroutine CT_register_restarts_to_file_2d(var, file_name, rest_file, mpp_domain, & - varname_prefix) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = register_restart_field(rest_file, & - file_name, var_name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_to_file_2d - -!> This subroutine registers the fields in a coupler_3d_bc_type to be saved -!! in restart files specified in the field table. -subroutine CT_register_restarts_3d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m, id_restart - - ocn_rest = .true. ; if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = register_restart_field(bc_rest_files(f), & - rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_3d - -!> This subroutine registers the fields in a coupler_3d_bc_type to be saved -!! in the specified restart file. -subroutine CT_register_restarts_to_file_3d(var, file_name, rest_file, mpp_domain, & - varname_prefix) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = register_restart_field(rest_file, & - file_name, var_name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_to_file_3d - - -!> This subroutine reads in the fields in a coupler_2d_bc_type that have -!! been saved in restart files. -subroutine CT_restore_state_2d(var, directory, all_or_nothing, & - all_required, test_by_field) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. ; all_set = .true. ; num_fld = 0 ; unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. ; all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest, & - directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL, & - "CT_restore_state_2d: test_by_field is true, and "//& - trim(unset_varname)//" was not read but some other fields in "//& - trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL, & - "CT_restore_state_2d: all_or_nothing is true, and "//& - trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then ; if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_2d: all_required is true, but "//& - trim(unset_varname)//" was not read from its restart file.") - endif ; endif - -end subroutine CT_restore_state_2d - -!> This subroutine reads in the fields in a coupler_3d_bc_type that have -!! been saved in restart files. -subroutine CT_restore_state_3d(var, directory, all_or_nothing, & - all_required, test_by_field) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. ; all_set = .true. ; num_fld = 0 ; unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. ; all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest, & - directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL, & - "CT_restore_state_3d: test_by_field is true, and "//& - trim(unset_varname)//" was not read but some other fields in "//& - trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL, & - "CT_restore_state_3d: all_or_nothing is true, and "//& - trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then ; if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_3d: all_required is true, but "//& - trim(unset_varname)//" was not read from its restart file.") - endif ; endif - -end subroutine CT_restore_state_3d - - -!> This subroutine potentially overrides the values in a coupler_2d_bc_type -subroutine CT_data_override_2d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_data_override_2d - -!> This subroutine potentially overrides the values in a coupler_3d_bc_type -subroutine CT_data_override_3d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_data_override_3d - - -!> This subroutine writes out checksums for the elements of a coupler_2d_bc_type -subroutine CT_write_chksums_2d(var, outunit, name_lead) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics - integer, intent(in) :: outunit !< The index of a open output file - character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names - - character(len=120) :: var_name - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') trim(var_name), & - mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec) ) - enddo ; enddo - -end subroutine CT_write_chksums_2d - -!> This subroutine writes out checksums for the elements of a coupler_3d_bc_type -subroutine CT_write_chksums_3d(var, outunit, name_lead) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics - integer, intent(in) :: outunit !< The index of a open output file - character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names - - character(len=120) :: var_name - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') var_name, & - mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec,:) ) - enddo ; enddo - -end subroutine CT_write_chksums_3d - - -!> This function indicates whether a coupler_1d_bc_type has been initialized. -function CT_initialized_1d(var) - type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_1d !< The return value, indicating whether this type has been initialized - - CT_initialized_1d = var%set -end function CT_initialized_1d - -!> This function indicates whether a coupler_2d_bc_type has been initialized. -function CT_initialized_2d(var) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_2d !< The return value, indicating whether this type has been initialized - - CT_initialized_2d = var%set -end function CT_initialized_2d - -!> This function indicates whether a coupler_3d_bc_type has been initialized. -function CT_initialized_3d(var) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_3d !< The return value, indicating whether this type has been initialized - - CT_initialized_3d = var%set -end function CT_initialized_3d - - -!> This subroutine deallocates all data associated with a coupler_1d_bc_type -subroutine CT_destructor_1d(var) - type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_1d - -!> This subroutine deallocates all data associated with a coupler_2d_bc_type -subroutine CT_destructor_2d(var) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_2d - - -!> This subroutine deallocates all data associated with a coupler_3d_bc_type -subroutine CT_destructor_3d(var) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_3d - -end module coupler_types_mod diff --git a/config_src/ice_solo_driver/coupler_util.F90 b/config_src/ice_solo_driver/coupler_util.F90 deleted file mode 100644 index dde67c2976..0000000000 --- a/config_src/ice_solo_driver/coupler_util.F90 +++ /dev/null @@ -1,144 +0,0 @@ -module coupler_util - -! This file is part of MOM6. See LICENSE.md for the license. - -! This code provides a couple of interfaces to allow more transparent and -! robust extraction of the various fields in the coupler types. -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use coupler_types_mod, only : coupler_2d_bc_type, ind_flux, ind_alpha -use coupler_types_mod, only : ind_csurf - -implicit none ; private - -public :: extract_coupler_values, set_coupler_values -public :: ind_flux, ind_alpha, ind_csurf - -contains - -subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, & - is, ie, js, je, conversion) - type(coupler_2d_bc_type), intent(in) :: BC_struc - integer, intent(in) :: BC_index, BC_element - real, dimension(:,:), intent(out) :: array_out - integer, optional, intent(in) :: is, ie, js, je - real, optional, intent(in) :: conversion -! Arguments: BC_struc - The type from which the data is being extracted. -! (in) BC_index - The boundary condition number being extracted. -! (in) BC_element - The element of the boundary condition being extracted. -! This could be ind_csurf, ind_alpha, ind_flux or ind_deposition. -! (out) array_out - The array being filled with the input values. -! (in, opt) is, ie, js, je - The i- and j- limits of array_out to be filled. -! These must match the size of the corresponding value array or an -! error message is issued. -! (in, opt) conversion - A number that every element is multiplied by, to -! permit sign convention or unit conversion. - - real, pointer, dimension(:,:) :: Array_in - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_in => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_out,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_out,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_out,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_out,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_in,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - if (size(Array_in,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - i_offset = lbound(Array_in,1) - is0 - j_offset = lbound(Array_in,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - array_out(i,j) = conv * Array_in(i+i_offset,j+j_offset) - enddo ; enddo - -end subroutine extract_coupler_values - -subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, & - is, ie, js, je, conversion) - real, dimension(:,:), intent(in) :: array_in - type(coupler_2d_bc_type), intent(inout) :: BC_struc - integer, intent(in) :: BC_index, BC_element - integer, optional, intent(in) :: is, ie, js, je - real, optional, intent(in) :: conversion -! Arguments: array_in - The array containing the values to load into the BC. -! (out) BC_struc - The type into which the data is being loaded. -! (in) BC_index - The boundary condition number being extracted. -! (in) BC_element - The element of the boundary condition being extracted. -! This could be ind_csurf, ind_alpha, ind_flux or ind_deposition. -! (in, opt) is, ie, js, je - The i- and j- limits of array_out to be filled. -! These must match the size of the corresponding value array or an -! error message is issued. -! (in, opt) conversion - A number that every element is multiplied by, to -! permit sign convention or unit conversion. - - real, pointer, dimension(:,:) :: Array_out - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_out => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_in,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_in,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_in,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_in,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_out,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - if (size(Array_out,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - i_offset = lbound(Array_out,1) - is0 - j_offset = lbound(Array_out,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - Array_out(i+i_offset,j+j_offset) = conv * array_in(i,j) - enddo ; enddo - -end subroutine set_coupler_values - -end module coupler_util diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index 7bfc7ec5ad..1d6f46427d 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -209,14 +209,14 @@ program SHELF_main call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ICE_SHELF", use_ice_shelf, & - "If true, call the code to apply an ice shelf model over \n"//& + "If true, call the code to apply an ice shelf model over "//& "some of the domain.", default=.false.) if (.not.use_ice_shelf) call MOM_error(FATAL, & "shelf_driver: ICE_SHELF must be defined.") call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", time_step, & - "The time step for changing forcing, coupling with other \n"//& + "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics.", & units="s", fail_if_missing=.true.) @@ -250,16 +250,16 @@ program SHELF_main Time_end = increment_date(Time, years, months, days, hours, minutes, seconds) call MOM_mesg('Segment run length determied from ice_solo_nml.', 2) call get_param(param_file, mdl, "DAYMAX", daymax, & - "The final time of the whole simulation, in units of \n"//& - "TIMEUNIT seconds. This also sets the potential end \n"//& - "time of the present run segment if the end time is \n"//& + "The final time of the whole simulation, in units of "//& + "TIMEUNIT seconds. This also sets the potential end "//& + "time of the present run segment if the end time is "//& "not set (as it was here) via ocean_solo_nml in input.nml.", & timeunit=Time_unit, default=Time_end) else call get_param(param_file, mdl, "DAYMAX", daymax, & - "The final time of the whole simulation, in units of \n"//& - "TIMEUNIT seconds. This also sets the potential end \n"//& - "time of the present run segment if the end time is \n"//& + "The final time of the whole simulation, in units of "//& + "TIMEUNIT seconds. This also sets the potential end "//& + "time of the present run segment if the end time is "//& "not set via ocean_solo_nml in input.nml.", & timeunit=Time_unit, fail_if_missing=.true.) Time_end = daymax @@ -271,14 +271,14 @@ program SHELF_main "MOM_driver: The run has been started at or after the end time of the run.") call get_param(param_file, mdl, "RESTART_CONTROL", Restart_control, & - "An integer whose bits encode which restart files are \n"//& - "written. Add 2 (bit 1) for a time-stamped file, and odd \n"//& - "(bit 0) for a non-time-stamped file. A non-time-stamped \n"//& - "restart file is saved at the end of the run segment \n"//& + "An integer whose bits encode which restart files are "//& + "written. Add 2 (bit 1) for a time-stamped file, and odd "//& + "(bit 0) for a non-time-stamped file. A non-time-stamped "//& + "restart file is saved at the end of the run segment "//& "for any non-negative value.", default=1) call get_param(param_file, mdl, "RESTINT", restint, & - "The interval between saves of the restart file in units \n"//& - "of TIMEUNIT. Use 0 (the default) to not save \n"//& + "The interval between saves of the restart file in units "//& + "of TIMEUNIT. Use 0 (the default) to not save "//& "incremental restart files at all.", default=set_time(0), & timeunit=Time_unit) call log_param(param_file, mdl, "ELAPSED TIME AS MASTER", elapsed_time_master) diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 33c66a3c40..2d899ce1bb 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -306,16 +306,16 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & @@ -323,13 +323,13 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index 28dc5305f1..1ce96fdac2 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -228,16 +228,16 @@ subroutine MESO_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & @@ -245,33 +245,33 @@ subroutine MESO_surface_forcing_init(Time, G, param_file, diag, CS) default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in \n"//& + "The file with the SST toward which to restore in "//& "variable TEMP.", fail_if_missing=.true.) call get_param(param_file, mdl, "SALINITYRESTORE_FILE", CS%salinityrestore_file, & - "The file with the surface salinity toward which to \n"//& + "The file with the surface salinity toward which to "//& "restore in variable SALT.", fail_if_missing=.true.) call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%heating_file, & - "The file with the non-shortwave heat flux in \n"//& + "The file with the non-shortwave heat flux in "//& "variable Heat.", fail_if_missing=.true.) call get_param(param_file, mdl, "PRECIP_FILE", CS%PmE_file, & - "The file with the net precipiation minus evaporation \n"//& + "The file with the net precipiation minus evaporation "//& "in variable PmE.", fail_if_missing=.true.) call get_param(param_file, mdl, "SHORTWAVE_FILE", CS%Solar_file, & - "The file with the shortwave heat flux in \n"//& + "The file with the shortwave heat flux in "//& "variable NET_SOL.", fail_if_missing=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") CS%inputdir = slasher(CS%inputdir) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 14890af0f8..22a216cb80 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -350,8 +350,8 @@ program MOM_main call log_version(param_file, mod_name, version, "") call get_param(param_file, mod_name, "DT", dt, fail_if_missing=.true.) call get_param(param_file, mod_name, "DT_FORCING", dt_forcing, & - "The time step for changing forcing, coupling with other \n"//& - "components, or potentially writing certain diagnostics. \n"//& + "The time step for changing forcing, coupling with other "//& + "components, or potentially writing certain diagnostics. "//& "The default value is given by DT.", units="s", default=dt) if (offline_tracer_mode) then call get_param(param_file, mod_name, "DT_OFFLINE", dt_forcing, & @@ -375,35 +375,35 @@ program MOM_main call get_param(param_file, mod_name, "DAYMAX", daymax, timeunit=Time_unit, & default=Time_end, do_not_log=.true.) call log_param(param_file, mod_name, "DAYMAX", daymax, & - "The final time of the whole simulation, in units of \n"//& - "TIMEUNIT seconds. This also sets the potential end \n"//& - "time of the present run segment if the end time is \n"//& + "The final time of the whole simulation, in units of "//& + "TIMEUNIT seconds. This also sets the potential end "//& + "time of the present run segment if the end time is "//& "not set via ocean_solo_nml in input.nml.", & timeunit=Time_unit) else call get_param(param_file, mod_name, "DAYMAX", daymax, & - "The final time of the whole simulation, in units of \n"//& - "TIMEUNIT seconds. This also sets the potential end \n"//& - "time of the present run segment if the end time is \n"//& + "The final time of the whole simulation, in units of "//& + "TIMEUNIT seconds. This also sets the potential end "//& + "time of the present run segment if the end time is "//& "not set via ocean_solo_nml in input.nml.", & timeunit=Time_unit, fail_if_missing=.true.) Time_end = daymax endif call get_param(param_file, mod_name, "SINGLE_STEPPING_CALL", single_step_call, & - "If true, advance the state of MOM with a single step \n"//& - "including both dynamics and thermodynamics. If false \n"//& + "If true, advance the state of MOM with a single step "//& + "including both dynamics and thermodynamics. If false "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mod_name, "DT_THERM", dt_therm, & - "The thermodynamic and tracer advection time step. \n"//& - "Ideally DT_THERM should be an integer multiple of DT \n"//& - "and less than the forcing or coupling time-step, unless \n"//& - "THERMO_SPANS_COUPLING is true, in which case DT_THERM \n"//& - "can be an integer multiple of the coupling timestep. By \n"//& + "The thermodynamic and tracer advection time step. "//& + "Ideally DT_THERM should be an integer multiple of DT "//& + "and less than the forcing or coupling time-step, unless "//& + "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& + "can be an integer multiple of the coupling timestep. By "//& "default DT_THERM is set to DT.", units="s", default=dt) call get_param(param_file, mod_name, "DIABATIC_FIRST", diabatic_first, & - "If true, apply diabatic and thermodynamic processes, \n"//& - "including buoyancy forcing and mass gain or loss, \n"//& + "If true, apply diabatic and thermodynamic processes, "//& + "including buoyancy forcing and mass gain or loss, "//& "before stepping the dynamics forward.", default=.false.) @@ -411,19 +411,19 @@ program MOM_main "MOM_driver: The run has been started at or after the end time of the run.") call get_param(param_file, mod_name, "RESTART_CONTROL", Restart_control, & - "An integer whose bits encode which restart files are \n"//& - "written. Add 2 (bit 1) for a time-stamped file, and odd \n"//& - "(bit 0) for a non-time-stamped file. A non-time-stamped \n"//& - "restart file is saved at the end of the run segment \n"//& + "An integer whose bits encode which restart files are "//& + "written. Add 2 (bit 1) for a time-stamped file, and odd "//& + "(bit 0) for a non-time-stamped file. A non-time-stamped "//& + "restart file is saved at the end of the run segment "//& "for any non-negative value.", default=1) call get_param(param_file, mod_name, "RESTINT", restint, & - "The interval between saves of the restart file in units \n"//& - "of TIMEUNIT. Use 0 (the default) to not save \n"//& + "The interval between saves of the restart file in units "//& + "of TIMEUNIT. Use 0 (the default) to not save "//& "incremental restart files at all.", default=real_to_time(0.0), & timeunit=Time_unit) call get_param(param_file, mod_name, "WRITE_CPU_STEPS", cpu_steps, & - "The number of coupled timesteps between writing the cpu \n"//& - "time. If this is not positive, do not check cpu time, and \n"//& + "The number of coupled timesteps between writing the cpu "//& + "time. If this is not positive, do not check cpu time, and "//& "the segment run-length can not be set via an elapsed CPU time.", & default=1000) call get_param(param_file, "MOM", "DEBUG", debug, & diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 75a1ec321a..6fe06daea8 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1392,7 +1392,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, '') call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & "The directory in which all input files are found.", & @@ -1400,39 +1400,39 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is \n"//& - "true. This assumes that KD = KDML = 0.0 and that \n"//& - "there is no buoyancy forcing, but makes the model \n"//& + "There are no diapycnal mass fluxes if ADIABATIC is "//& + "true. This assumes that KD = KDML = 0.0 and that "//& + "there is no buoyancy forcing, but makes the model "//& "faster by eliminating subroutine calls.", default=.false.) call get_param(param_file, mdl, "VARIABLE_WINDS", CS%variable_winds, & "If true, the winds vary in time after the initialization.", & default=.true.) call get_param(param_file, mdl, "VARIABLE_BUOYFORCE", CS%variable_buoyforce, & - "If true, the buoyancy forcing varies in time after the \n"//& + "If true, the buoyancy forcing varies in time after the "//& "initialization of the model.", default=.true.) call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & - "The character string that indicates how buoyancy forcing \n"//& - "is specified. Valid options include (file), (zero), \n"//& + "The character string that indicates how buoyancy forcing "//& + "is specified. Valid options include (file), (zero), "//& "(linear), (USER), (BFB) and (NONE).", fail_if_missing=.true.) if (trim(CS%buoy_config) == "file") then call get_param(param_file, mdl, "ARCHAIC_OMIP_FORCING_FILE", CS%archaic_OMIP_file, & - "If true, use the forcing variable decomposition from \n"//& - "the old German OMIP prescription that predated CORE. If \n"//& - "false, use the variable groupings available from MOM \n"//& + "If true, use the forcing variable decomposition from "//& + "the old German OMIP prescription that predated CORE. If "//& + "false, use the variable groupings available from MOM "//& "output diagnostics of forcing variables.", default=.true.) if (CS%archaic_OMIP_file) then call get_param(param_file, mdl, "LONGWAVEDOWN_FILE", CS%longwave_file, & - "The file with the downward longwave heat flux, in \n"//& + "The file with the downward longwave heat flux, in "//& "variable lwdn_sfc.", fail_if_missing=.true.) call get_param(param_file, mdl, "LONGWAVEUP_FILE", CS%longwaveup_file, & - "The file with the upward longwave heat flux, in \n"//& + "The file with the upward longwave heat flux, in "//& "variable lwup_sfc.", fail_if_missing=.true.) call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & - "The file with the evaporative moisture flux, in \n"//& + "The file with the evaporative moisture flux, in "//& "variable evap.", fail_if_missing=.true.) call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & - "The file with the sensible heat flux, in \n"//& + "The file with the sensible heat flux, in "//& "variable shflx.", fail_if_missing=.true.) call get_param(param_file, mdl, "SHORTWAVEUP_FILE", CS%shortwaveup_file, & "The file with the upward shortwave heat flux.", & @@ -1441,13 +1441,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The file with the downward shortwave heat flux.", & fail_if_missing=.true.) call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & - "The file with the downward frozen precip flux, in \n"//& + "The file with the downward frozen precip flux, in "//& "variable snow.", fail_if_missing=.true.) call get_param(param_file, mdl, "PRECIP_FILE", CS%rain_file, & - "The file with the downward total precip flux, in \n"//& + "The file with the downward total precip flux, in "//& "variable precip.", fail_if_missing=.true.) call get_param(param_file, mdl, "FRESHDISCHARGE_FILE", CS%runoff_file, & - "The file with the fresh and frozen runoff/calving fluxes, \n"//& + "The file with the fresh and frozen runoff/calving fluxes, "//& "invariables disch_w and disch_s.", fail_if_missing=.true.) ! These variable names are hard-coded, per the archaic OMIP conventions. @@ -1458,52 +1458,52 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C else call get_param(param_file, mdl, "LONGWAVE_FILE", CS%longwave_file, & - "The file with the longwave heat flux, in the variable \n"//& + "The file with the longwave heat flux, in the variable "//& "given by LONGWAVE_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "LONGWAVE_FORCING_VAR", CS%LW_var, & "The variable with the longwave forcing field.", default="LW") call get_param(param_file, mdl, "SHORTWAVE_FILE", CS%shortwave_file, & - "The file with the shortwave heat flux, in the variable \n"//& + "The file with the shortwave heat flux, in the variable "//& "given by SHORTWAVE_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SHORTWAVE_FORCING_VAR", CS%SW_var, & "The variable with the shortwave forcing field.", default="SW") call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & - "The file with the evaporative moisture flux, in the \n"//& + "The file with the evaporative moisture flux, in the "//& "variable given by EVAP_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "EVAP_FORCING_VAR", CS%evap_var, & "The variable with the evaporative moisture flux.", & default="evap") call get_param(param_file, mdl, "LATENTHEAT_FILE", CS%latentheat_file, & - "The file with the latent heat flux, in the variable \n"//& + "The file with the latent heat flux, in the variable "//& "given by LATENT_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "LATENT_FORCING_VAR", CS%latent_var, & "The variable with the latent heat flux.", default="latent") call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & - "The file with the sensible heat flux, in the variable \n"//& + "The file with the sensible heat flux, in the variable "//& "given by SENSIBLE_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SENSIBLE_FORCING_VAR", CS%sens_var, & "The variable with the sensible heat flux.", default="sensible") call get_param(param_file, mdl, "RAIN_FILE", CS%rain_file, & - "The file with the liquid precipitation flux, in the \n"//& + "The file with the liquid precipitation flux, in the "//& "variable given by RAIN_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "RAIN_FORCING_VAR", CS%rain_var, & "The variable with the liquid precipitation flux.", & default="liq_precip") call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & - "The file with the frozen precipitation flux, in the \n"//& + "The file with the frozen precipitation flux, in the "//& "variable given by SNOW_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SNOW_FORCING_VAR", CS%snow_var, & "The variable with the frozen precipitation flux.", & default="froz_precip") call get_param(param_file, mdl, "RUNOFF_FILE", CS%runoff_file, & - "The file with the fresh and frozen runoff/calving \n"//& - "fluxes, in variables given by LIQ_RUNOFF_FORCING_VAR \n"//& + "The file with the fresh and frozen runoff/calving "//& + "fluxes, in variables given by LIQ_RUNOFF_FORCING_VAR "//& "and FROZ_RUNOFF_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "LIQ_RUNOFF_FORCING_VAR", CS%lrunoff_var, & "The variable with the liquid runoff flux.", & @@ -1514,10 +1514,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C endif call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in the \n"//& + "The file with the SST toward which to restore in the "//& "variable given by SST_RESTORE_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SALINITYRESTORE_FILE", CS%salinityrestore_file, & - "The file with the surface salinity toward which to \n"//& + "The file with the surface salinity toward which to "//& "restore in the variable given by SSS_RESTORE_VAR.", & fail_if_missing=.true.) @@ -1549,17 +1549,17 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%salinityrestore_file = trim(CS%inputdir)//trim(CS%salinityrestore_file) elseif (trim(CS%buoy_config) == "const") then call get_param(param_file, mdl, "SENSIBLE_HEAT_FLUX", CS%constantHeatForcing, & - "A constant heat forcing (positive into ocean) applied \n"//& + "A constant heat forcing (positive into ocean) applied "//& "through the sensible heat flux field. ", & units='W/m2', fail_if_missing=.true.) endif call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & - "The character string that indicates how wind forcing \n"//& - "is specified. Valid options include (file), (2gyre), \n"//& + "The character string that indicates how wind forcing "//& + "is specified. Valid options include (file), (2gyre), "//& "(1gyre), (gyres), (zero), and (USER).", fail_if_missing=.true.) if (trim(CS%wind_config) == "file") then call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & - "The file in which the wind stresses are found in \n"//& + "The file in which the wind stresses are found in "//& "variables STRESS_X and STRESS_Y.", fail_if_missing=.true.) call get_param(param_file, mdl, "WINDSTRESS_X_VAR",CS%stress_x_var, & "The name of the x-wind stress variable in WIND_FILE.", & @@ -1568,37 +1568,37 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The name of the y-wind stress variable in WIND_FILE.", & default="STRESS_Y") call get_param(param_file, mdl, "WINDSTRESS_STAGGER",CS%wind_stagger, & - "A character indicating how the wind stress components \n"//& + "A character indicating how the wind stress components "//& "are staggered in WIND_FILE. This may be A or C for now.", & default="A") call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & "A value by which the wind stresses in WIND_FILE are rescaled.", & default=1.0, units="nondim") call get_param(param_file, mdl, "USTAR_FORCING_VAR", CS%ustar_var, & - "The name of the friction velocity variable in WIND_FILE \n"//& - "or blank to get ustar from the wind stresses plus the \n"//& + "The name of the friction velocity variable in WIND_FILE "//& + "or blank to get ustar from the wind stresses plus the "//& "gustiness.", default=" ", units="nondim") CS%wind_file = trim(CS%inputdir) // trim(CS%wind_file) endif if (trim(CS%wind_config) == "gyres") then call get_param(param_file, mdl, "TAUX_CONST", CS%gyres_taux_const, & - "With the gyres wind_config, the constant offset in the \n"//& - "zonal wind stress profile: \n"//& + "With the gyres wind_config, the constant offset in the "//& + "zonal wind stress profile: "//& " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="Pa", default=0.0) call get_param(param_file, mdl, "TAUX_SIN_AMP",CS%gyres_taux_sin_amp, & - "With the gyres wind_config, the sine amplitude in the \n"//& - "zonal wind stress profile: \n"//& + "With the gyres wind_config, the sine amplitude in the "//& + "zonal wind stress profile: "//& " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="Pa", default=0.0) call get_param(param_file, mdl, "TAUX_COS_AMP",CS%gyres_taux_cos_amp, & - "With the gyres wind_config, the cosine amplitude in \n"//& - "the zonal wind stress profile: \n"//& + "With the gyres wind_config, the cosine amplitude in "//& + "the zonal wind stress profile: "//& " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="Pa", default=0.0) call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & - "With the gyres wind_config, the number of gyres in \n"//& - "the zonal wind stress profile: \n"//& + "With the gyres wind_config, the number of gyres in "//& + "the zonal wind stress profile: "//& " n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="nondim", default=0.0) endif @@ -1610,14 +1610,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%len_lat = G%len_lat endif call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", units="J/kg", default=hlf) @@ -1625,20 +1625,20 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The latent heat of fusion.", units="J/kg", default=hlv) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) if (CS%use_temperature) then call get_param(param_file, mdl, "FLUXCONST_T", CS%Flux_const_T, & - "The constant that relates the restoring surface temperature\n"//& - "flux to the relative surface anomaly (akin to a piston \n"//& + "The constant that relates the restoring surface temperature "//& + "flux to the relative surface anomaly (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & default=CS%Flux_const) call get_param(param_file, mdl, "FLUXCONST_S", CS%Flux_const_S, & - "The constant that relates the restoring surface salinity\n"//& - "flux to the relative surface anomaly (akin to a piston \n"//& + "The constant that relates the restoring surface salinity "//& + "flux to the relative surface anomaly (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & default=CS%Flux_const) endif @@ -1650,20 +1650,20 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C if (trim(CS%buoy_config) == "linear") then call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & - "With buoy_config linear, the sea surface temperature \n"//& - "at the northern end of the domain toward which to \n"//& + "With buoy_config linear, the sea surface temperature "//& + "at the northern end of the domain toward which to "//& "to restore.", units="deg C", default=0.0) call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & - "With buoy_config linear, the sea surface temperature \n"//& - "at the southern end of the domain toward which to \n"//& + "With buoy_config linear, the sea surface temperature "//& + "at the southern end of the domain toward which to "//& "to restore.", units="deg C", default=0.0) call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & - "With buoy_config linear, the sea surface salinity \n"//& - "at the northern end of the domain toward which to \n"//& + "With buoy_config linear, the sea surface salinity "//& + "at the northern end of the domain toward which to "//& "to restore.", units="PSU", default=35.0) call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & - "With buoy_config linear, the sea surface salinity \n"//& - "at the southern end of the domain toward which to \n"//& + "With buoy_config linear, the sea surface salinity "//& + "at the southern end of the domain toward which to "//& "to restore.", units="PSU", default=35.0) endif endif @@ -1675,11 +1675,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The background gustiness in the winds.", units="Pa", & default=0.02) call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from \n"//& + "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in \n"//& + "The file in which the wind gustiness is found in "//& "variable gustiness.", fail_if_missing=.true.) call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) filename = trim(CS%inputdir) // trim(gust_file) @@ -1704,10 +1704,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call idealized_hurricane_wind_init(Time, G, param_file, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "const") then call get_param(param_file, mdl, "CONST_WIND_TAUX", CS%tau_x0, & - "With wind_config const, this is the constant zonal\n"//& + "With wind_config const, this is the constant zonal "//& "wind-stress", units="Pa", fail_if_missing=.true.) call get_param(param_file, mdl, "CONST_WIND_TAUY", CS%tau_y0, & - "With wind_config const, this is the constant meridional\n"//& + "With wind_config const, this is the constant meridional "//& "wind-stress", units="Pa", fail_if_missing=.true.) elseif (trim(CS%wind_config) == "SCM_CVmix_tests" .or. & trim(CS%buoy_config) == "SCM_CVmix_tests") then diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index 94726a62c3..71e91a539c 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -233,16 +233,16 @@ subroutine Neverland_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) ! call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & @@ -250,14 +250,14 @@ subroutine Neverland_surface_forcing_init(Time, G, param_file, diag, CS) ! default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) ! Convert CS%flux_const from m day-1 to m s-1. diff --git a/config_src/solo_driver/coupler_types.F90 b/config_src/solo_driver/coupler_types.F90 deleted file mode 100644 index 10d22a8eff..0000000000 --- a/config_src/solo_driver/coupler_types.F90 +++ /dev/null @@ -1,3310 +0,0 @@ -!> This module contains the coupler-type declarations and methods for use in -!! ocean-only configurations of MOM6. -!! -!! It is intended that the version of coupler_types_mod that is avialable from -!! FMS will conform to this version with the FMS city release after warsaw. - -module coupler_types_mod - -! This file is part of MOM6. See LICENSE.md for the license. - -use fms_io_mod, only: restart_file_type, register_restart_field -use fms_io_mod, only: query_initialized, restore_state -use time_manager_mod, only: time_type -use diag_manager_mod, only: register_diag_field, send_data -use data_override_mod, only: data_override -use mpp_domains_mod, only: domain2D, mpp_redistribute -use mpp_mod, only: stdout, mpp_error, FATAL, mpp_chksum - -implicit none ; private - -public coupler_type_copy, coupler_type_spawn, coupler_type_set_diags -public coupler_type_write_chksums, coupler_type_send_data, coupler_type_data_override -public coupler_type_register_restarts, coupler_type_restore_state -public coupler_type_increment_data, coupler_type_rescale_data -public coupler_type_copy_data, coupler_type_redistribute_data -public coupler_type_destructor, coupler_type_initialized -public coupler_type_extract_data, coupler_type_set_data - -public coupler_type_copy_1d_2d -public coupler_type_copy_1d_3d - - -! -! 3-d fields -! -!> A type with a 3-d array of values and metadata -type, public :: coupler_3d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_3d_values_type - -!> A field with one or more related 3-d variables and collective metadata -type, public :: coupler_3d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_3d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_3d_field_type - -!> A collection of 3-D boundary conditions for exchange between components -type, public :: coupler_3d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - !>@{ The i- and j-direction data and computational domain index ranges for this type - integer :: isd, isc, iec, ied ! The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed ! The j-direction data and computational domain index ranges for this type - !!@} - integer :: ks !< The k-direction start index for this type - integer :: ke !< The k-direction end index for this type -end type coupler_3d_bc_type - -! -! 2-d fields -! -!> A type with a 2-d array of values and metadata -type, public :: coupler_2d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_2d_values_type - -!> A field with one or more related 2-d variables and collective metadata -type, public :: coupler_2d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_2d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_2d_field_type - -!> A collection of 2-D boundary conditions for exchange between components -type, public :: coupler_2d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - !>@{ The i- and j-direction data and computational domain index ranges for this type - integer :: isd, isc, iec, ied ! The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed ! The j-direction data and computational domain index ranges for this type - !!@} -end type coupler_2d_bc_type - -! -! 1-d fields -! -!> A type with a 1-d array of values and metadata -type, public :: coupler_1d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, dimension(:) :: values => NULL() !< The pointer to the array of values - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file -end type coupler_1d_values_type - -!> A field with one or more related 1-d variables and collective metadata -type, public :: coupler_1d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_1d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt -end type coupler_1d_field_type - -!> A collection of 1-D boundary conditions for exchange between components -type, public :: coupler_1d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized -end type coupler_1d_bc_type - -!---------------------------------------------------------------------- -! The following public parameters can help in selecting the sub-elements of a -! coupler type. There are duplicate values because different boundary -! conditions have different sub-elements. -integer, parameter, public :: ind_pcair = 1 !< The index of the atmospheric concentration -integer, parameter, public :: ind_u10 = 2 !< The index of the 10 m wind speed -integer, parameter, public :: ind_psurf = 3 !< The index of the surface atmospheric pressure -integer, parameter, public :: ind_alpha = 1 !< The index of the solubility array for a tracer -integer, parameter, public :: ind_csurf = 2 !< The index of the ocean surface concentration -integer, parameter, public :: ind_sc_no = 3 !< The index for the Schmidt number for a tracer flux -integer, parameter, public :: ind_flux = 1 !< The index for the tracer flux -integer, parameter, public :: ind_deltap= 2 !< The index for ocean-air gas partial pressure change -integer, parameter, public :: ind_kw = 3 !< The index for the piston velocity -integer, parameter, public :: ind_deposition = 1 !< The index for the atmospheric deposition flux -integer, parameter, public :: ind_runoff = 1 !< The index for a runoff flux - -!---------------------------------------------------------------------- -! Interface definitions for overloaded routines -!---------------------------------------------------------------------- - -!> This is the interface to spawn one coupler_bc_type into another and then -!! register diagnostics associated with the new type. -interface coupler_type_copy - module procedure coupler_type_copy_1d_2d, coupler_type_copy_1d_3d - module procedure coupler_type_copy_2d_2d, coupler_type_copy_2d_3d - module procedure coupler_type_copy_3d_2d, coupler_type_copy_3d_3d -end interface coupler_type_copy - -!> This is the interface to spawn one coupler_bc_type into another. -interface coupler_type_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d, CT_spawn_3d_2d - module procedure CT_spawn_1d_3d, CT_spawn_2d_3d, CT_spawn_3d_3d -end interface coupler_type_spawn - -!> This is the interface to copy the field data from one coupler_bc_type -!! to another of the same rank, size and decomposition. -interface coupler_type_copy_data - module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d -end interface coupler_type_copy_data - -!> This is the interface to redistribute the field data from one coupler_bc_type -!! to another of the same rank and global size, but a different decomposition. -interface coupler_type_redistribute_data - module procedure CT_redistribute_data_2d, CT_redistribute_data_3d -end interface coupler_type_redistribute_data - -!> This is the interface to rescale the field data in a coupler_bc_type. -interface coupler_type_rescale_data - module procedure CT_rescale_data_2d, CT_rescale_data_3d -end interface coupler_type_rescale_data - -!> This is the interface to increment the field data from one coupler_bc_type -!! with the data from another. Both must have the same horizontal size and -!! decomposition, but a 2d type may be incremented by a 2d or 3d type -interface coupler_type_increment_data - module procedure CT_increment_data_2d_2d, CT_increment_data_3d_3d, CT_increment_data_2d_3d -end interface coupler_type_increment_data - -!> This is the interface to extract a field in a coupler_bc_type into an array. -interface coupler_type_extract_data - module procedure CT_extract_data_2d, CT_extract_data_3d, CT_extract_data_3d_2d -end interface coupler_type_extract_data - -!> This is the interface to set a field in a coupler_bc_type from an array. -interface coupler_type_set_data - module procedure CT_set_data_2d, CT_set_data_3d, CT_set_data_2d_3d -end interface coupler_type_set_data - -!> This is the interface to set diagnostics for the arrays in a coupler_bc_type. -interface coupler_type_set_diags - module procedure CT_set_diags_2d, CT_set_diags_3d -end interface coupler_type_set_diags - -!> This is the interface to write out checksums for the elements of a coupler_bc_type. -interface coupler_type_write_chksums - module procedure CT_write_chksums_2d, CT_write_chksums_3d -end interface coupler_type_write_chksums - -!> This is the interface to write out diagnostics of the arrays in a coupler_bc_type. -interface coupler_type_send_data - module procedure CT_send_data_2d, CT_send_data_3d -end interface coupler_type_send_data - -!> This is the interface to override the values of the arrays in a coupler_bc_type. -interface coupler_type_data_override - module procedure CT_data_override_2d, CT_data_override_3d -end interface coupler_type_data_override - -!> This is the interface to register the fields in a coupler_bc_type to be saved -!! in restart files. -interface coupler_type_register_restarts - module procedure CT_register_restarts_2d, CT_register_restarts_3d - module procedure CT_register_restarts_to_file_2d, CT_register_restarts_to_file_3d -end interface coupler_type_register_restarts - -!> This is the interface to read in the fields in a coupler_bc_type that have -!! been saved in restart files. -interface coupler_type_restore_state - module procedure CT_restore_state_2d, CT_restore_state_3d -end interface coupler_type_restore_state - -!> This function interface indicates whether a coupler_bc_type has been initialized. -interface coupler_type_initialized - module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d -end interface coupler_type_initialized - -!> This is the interface to deallocate any data associated with a coupler_bc_type. -interface coupler_type_destructor - module procedure CT_destructor_1d, CT_destructor_2d, CT_destructor_3d -end interface coupler_type_destructor - -contains - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 1-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_1d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_1d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_1d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 1-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_1d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_1d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_1d_3d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 2-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_2d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_2d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_2d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 2-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_2d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_2d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_2d_3d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 3-D to 2-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & - diag_name, axes, time, suffix) - - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_3d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_3d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_2d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_3d_2d - -!####################################################################### -!> \brief Copy fields from one coupler type to another. 3-D to 3-D version for generic coupler_type_copy. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_copy(var_in, var_out, is, ie, js, je, kd, & -!! diag_name, axes, time, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -!! \throw FATAL, "axes less than 3 elements" -subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & - diag_name, axes, time, suffix) - - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (coupler_type_copy_3d_3d):' - character(len=400) :: error_msg - integer :: m, n - - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0) & - call CT_spawn_3d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & - call CT_set_diags_3d(var_out, diag_name, axes, time) - -end subroutine coupler_type_copy_3d_3d - - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 1-D to 2-D version for generic coupler_type_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var_out, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var_out%bc already associated" -!! \throw FATAL, "var_out%bc([n])%field already associated" -!! \throw FATAL, "var_out%bc([n])%field([m])%values already associated" -subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) - - type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_1d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_1d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 1-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) - - type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in - !! a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_1d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_1d_3d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 2-D to 2-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) - - type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_2d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_2d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 2-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) - - type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in - !! a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_2d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_2d_3d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 3-D to 2-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) - - type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_3d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_3d_2d - -!####################################################################### -!> \brief Generate one coupler type using another as a template. 3-D to 3-D version for generic CT_spawn. -!! -!! Template: -!! -!! ~~~~~~~~~~{.f90} -!! call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix = 'something') -!! ~~~~~~~~~~ -!! -!! \throw FATAL, "Number of output fields is non-zero" -!! \throw FATAL, "var%bc already associated" -!! \throw FATAL, "var%bc([n])%field already associated" -!! \throw FATAL, "var%bc([n])%field([m])%values already associated" -subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) - - type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in - !! a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_spawn_3d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then ; if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif ; endif - - if (var%set) & - call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set) & - call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs ; var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - - endif - -end subroutine CT_spawn_3d_3d - - -!> This subroutine does a direct copy of the data in all elements of one -!! coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: copy_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_2d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_2d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_2d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_2d - -!> This subroutine does a direct copy of the data in all elements of one -!! coupler_3d_bc_type into another. Both types must have the same array sizes. -subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks)) & - call mpp_error(FATAL, "CT_copy_data_3d: There is a k-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc ; k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_3d - -!> This subroutine does a direct copy of the data in all elements of a -!! coupler_2d_bc_type into a coupler_3d_bc_type. Both types must have the same -!! array sizes for their first two dimensions, while the extent of the 3rd dimension -!! that is being filled may be specified via optional arguments. -subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice, & - ind3_start, ind3_end) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd - !! index of the 3d type to fill in. - integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd - !! index of the 3d type to fill in. - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, ks, ke - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the output structure.") - endif - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - do n = n1, n2 - - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type)) & - copy_bc = .not.(trim(var_in%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type)) & - copy_bc = (trim(var_in%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice)) & - copy_bc = (pass_through_ice .eqv. var_in%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - ks = var%ks ; if (present(ind3_start)) ks = max(ks, ind3_start) - ke = var%ke ; if (present(ind3_end)) ke = max(ke, ind3_end) - do k=ks,ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_copy_data_2d_3d - - -!> This subroutine redistributes the data in all elements of one coupler_2d_bc_type -!! into another, which may be on different processors with a different decomposition. -subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy (intent in) - type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure - type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) - type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure - logical, optional, intent(in) :: complete !< If true, complete the updates - - real, pointer, dimension(:,:) :: null_ptr2D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. ; if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 ; fc_out = 0 - if (do_in) then ; do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo ; enddo ; endif - if (fc_in == 0) do_in = .false. - if (do_out) then ; do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo ; enddo ; endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL, & - "Mismatch in num_bcs in CT_copy_data_2d.") - if (fc_in /= fc_out) call mpp_error(FATAL, & - "Mismatch in the total number of fields in CT_redistribute_data_2d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv. & - associated(var_out%bc(n)%field(m)%values) ) & - call mpp_error(FATAL, & - "Mismatch in which fields are associated in CT_redistribute_data_2d.") - - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_in) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, null_ptr2D, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_out) then - do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr2D, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo ; enddo - endif - -end subroutine CT_redistribute_data_2d - -!> This subroutine redistributes the data in all elements of one coupler_2d_bc_type -!! into another, which may be on different processors with a different decomposition. -subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy (intent in) - type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure - type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) - type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure - logical, optional, intent(in) :: complete !< If true, complete the updates - - real, pointer, dimension(:,:,:) :: null_ptr3D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. ; if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 ; fc_out = 0 - if (do_in) then ; do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo ; enddo ; endif - if (fc_in == 0) do_in = .false. - if (do_out) then ; do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo ; enddo ; endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL, & - "Mismatch in num_bcs in CT_copy_data_3d.") - if (fc_in /= fc_out) call mpp_error(FATAL, & - "Mismatch in the total number of fields in CT_redistribute_data_3d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv. & - associated(var_out%bc(n)%field(m)%values) ) & - call mpp_error(FATAL, & - "Mismatch in which fields are associated in CT_redistribute_data_3d.") - - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_in) then - do n = 1, var_in%num_bcs ; do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values, & - domain_out, null_ptr3D, & - complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo ; enddo - elseif (do_out) then - do n = 1, var_out%num_bcs ; do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr3D, & - domain_out, var_out%bc(n)%field(m)%values, & - complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo ; enddo - endif - -end subroutine CT_redistribute_data_3d - - -!> This subroutine rescales the fields in the elements of a coupler_2d_bc_type -!! by multiplying by a factor scale. If scale is 0, this is a direct -!! assignment to 0, so that NaNs will not persist. -subroutine CT_rescale_data_2d(var, scale, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or - !! the full arrays if scale is 0. - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: do_bc - integer :: i, j, m, n, n1, n2, halo - - if (present(bc_index)) then - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.") - if (present(field_index)) then ; if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_2d: Excessive i-direction halo size.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_2d: Excessive j-direction halo size.") - endif - - do n = n1, n2 - - do_bc = .true. - if (do_bc .and. present(exclude_flux_type)) & - do_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (do_bc .and. present(only_flux_type)) & - do_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (do_bc .and. present(pass_through_ice)) & - do_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.do_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - if (scale == 0.0) then - if (present(halo_size)) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = 0.0 - enddo ; enddo - else - var%bc(n)%field(m)%values(:,:) = 0.0 - endif - else - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = scale * var%bc(n)%field(m)%values(i,j) - enddo ; enddo - endif - endif - enddo - enddo - -end subroutine CT_rescale_data_2d - -!> This subroutine rescales the fields in the elements of a coupler_3d_bc_type -!! by multiplying by a factor scale. If scale is 0, this is a direct -!! assignment to 0, so that NaNs will not persist. -subroutine CT_rescale_data_3d(var, scale, halo_size, bc_index, field_index, & - exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or - !! the full arrays if scale is 0. - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: do_bc - integer :: i, j, k, m, n, n1, n2, halo - - if (present(bc_index)) then - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.") - if (present(field_index)) then ; if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_rescale_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_3d: Excessive i-direction halo size.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_rescale_data_3d: Excessive j-direction halo size.") - endif - - do n = n1, n2 - - do_bc = .true. - if (do_bc .and. present(exclude_flux_type)) & - do_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (do_bc .and. present(only_flux_type)) & - do_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (do_bc .and. present(pass_through_ice)) & - do_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.do_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - if (scale == 0.0) then - if (present(halo_size)) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = 0.0 - enddo ; enddo ; enddo - else - var%bc(n)%field(m)%values(:,:,:) = 0.0 - endif - else - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = scale * var%bc(n)%field(m)%values(i,j,k) - enddo ; enddo ; enddo - endif - endif - enddo - enddo - -end subroutine CT_rescale_data_3d - - -!> This subroutine does a direct increment of the data in all elements of one -!! coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this increment. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_2d_2d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_2d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_2d: There is a j-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = sc_prev * var%bc(n)%field(m)%values(i,j) + & - scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_2d_2d - - -!> This subroutine does a direct increment of the data in all elements of one -!! coupler_3d_bc_type into another. Both must have the same array sizes. -subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this increment. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_3d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is a j-direction computional domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks)) & - call mpp_error(FATAL, "CT_increment_data_3d: There is a k-direction computional domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc ; j_off = var_in%jsc - var%jsc ; k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = sc_prev * var%bc(n)%field(m)%values(i,j,k) + & - scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_3d_3d - -!> This subroutine does increments the data in the elements of a coupler_2d_bc_type -!! with the weighed average of the elements of a coupler_3d_bc_type. Both must have -!! the same horizontal array sizes and the normalized weight array must match the -!! array sizes of the coupler_3d_bc_type. -subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, field_index, & - scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type - real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to - !! increment the 2d-data. There is no renormalization, - !! so if the weights do not sum to 1 in the 3rd dimension - !! there may be adverse consequences! - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this increment. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, k, m, n, n1, n2, halo - integer :: io1, jo1, iow, jow, kow ! Offsets to account for different index conventions. - - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 ; if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: field_index is present and exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_2d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - - n1 = 1 ; n2 = var_in%num_bcs - if (present(bc_index)) then ; n1 = bc_index ; n2 = bc_index ; endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is an i-direction computional domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is a j-direction computional domain size mismatch.") - if ((1+var_in%ke-var_in%ks) /= size(weights,3)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: There is a k-direction size mismatch with the weights array.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, "CT_increment_data_2d_3d: Excessive j-direction halo size for the output structure.") - - if ((1+var%iec-var%isc) == size(weights,1)) then - iow = 1 - var%isc - elseif ((1+var%ied-var%isd) == size(weights,1)) then - iow = 1 - var%isd - elseif ((1+var_in%ied-var_in%isd) == size(weights,1)) then - iow = 1 + (var_in%isc - var_in%isd) - var%isc - else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size "//& - "of a computational or data domain.") - endif - if ((1+var%jec-var%jsc) == size(weights,2)) then - jow = 1 - var%jsc - elseif ((1+var%jed-var%jsd) == size(weights,2)) then - jow = 1 - var%jsd - elseif ((1+var_in%jed-var_in%jsd) == size(weights,2)) then - jow = 1 + (var_in%jsc - var_in%jsd) - var%jsc - else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size "//& - "of a computational or data domain.") - endif - - io1 = var_in%isc - var%isc ; jo1 = var_in%jsc - var%jsc ; kow = 1 - var_in%ks - endif - - do n = n1, n2 - - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type)) & - increment_bc = .not.(trim(var_in%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type)) & - increment_bc = (trim(var_in%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice)) & - increment_bc = (pass_through_ice .eqv. var_in%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then ; if (m /= field_index) cycle ; endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var_in%ks,var_in%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = sc_prev * var%bc(n)%field(m)%values(i,j) + & - (scale * weights(i+iow,j+jow,k+kow)) * var_in%bc(n)%field(m)%values(i+io1,j+io1,k) - enddo ; enddo ; enddo - endif - enddo - enddo - -end subroutine CT_increment_data_2d_3d - - -!> This subroutine extracts a single 2-d field from a coupler_2d_bc_type into -!! a two-dimensional array. -subroutine CT_extract_data_2d(var_in, bc_index, field_index, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j) - enddo ; enddo - -end subroutine CT_extract_data_2d - -!> This subroutine extracts a single k-level of a 3-d field from a coupler_3d_bc_type -!! into a two-dimensional array. -subroutine CT_extract_data_3d_2d(var_in, bc_index, field_index, k_in, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - integer, intent(in) :: k_in !< The k-index to extract - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_3d_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if ((k_in > var_in%ke) .or. (k_in < var_in%ks)) then - write (error_msg, *) trim(error_header), ' The extracted k-index of ', k_in, & - ' is outside of the valid range of ', var_in%ks, ' to ', var_in%ke - call mpp_error(FATAL, trim(error_msg)) - endif - - do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k_in) - enddo ; enddo - -end subroutine CT_extract_data_3d_2d - -!> This subroutine extracts a single 3-d field from a coupler_3d_bc_type into -!! a three-dimensional array. -subroutine CT_extract_data_3d(var_in, bc_index, field_index, array_out, & - scale_factor, halo_size, idim, jdim) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, dimension(1:,1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_extract_data_3d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off, k_off - - if (bc_index <= 0) then - array_out(:,:,:) = 0.0 - return - endif - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_out,1), ' does not match the data of size ', & - (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_out,2), ' does not match the data of size ', & - (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if (size(array_out,3) /= 1 + var_in%ke - var_in%ks) then - write (error_msg, *) trim(error_header), ' The target array with k-dimension size ', & - size(array_out,3), ' does not match the data of size ', & - (1 + var_in%ke - var_in%ks) - call mpp_error(FATAL, trim(error_msg)) - endif - k_off = 1 - var_in%ks - - do k=var_in%ks,var_in%ke ; do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off,k+k_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k) - enddo ; enddo ; enddo - -end subroutine CT_extract_data_3d - - -!> This subroutine sets a single 2-d field in a coupler_3d_bc_type from -!! a two-dimensional array. -subroutine CT_set_data_2d(array_in, bc_index, field_index, var, & - scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j) = scale * array_in(i+i_off,j+j_off) - enddo ; enddo - -end subroutine CT_set_data_2d - -!> This subroutine sets a one k-level of a single 3-d field in a -!! coupler_3d_bc_type from a two-dimensional array. -subroutine CT_set_data_2d_3d(array_in, bc_index, field_index, k_out, var, & - scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - integer, intent(in) :: k_out !< The k-index to set - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_3d_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - if ((k_out > var%ke) .or. (k_out < var%ks)) then - write (error_msg, *) trim(error_header), ' The seted k-index of ', k_out, & - ' is outside of the valid range of ', var%ks, ' to ', var%ke - call mpp_error(FATAL, trim(error_msg)) - endif - - do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j,k_out) = scale * array_in(i+i_off,j+j_off) - enddo ; enddo - -end subroutine CT_set_data_2d_3d - -!> This subroutine sets a single 3-d field in a coupler_3d_bc_type from -!! a three-dimensional array. -subroutine CT_set_data_3d(array_in, bc_index, field_index, var, & - scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:,1:), intent(in) :: array_in !< The source array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=256), parameter :: error_header = & - '==>Error from coupler_types_mod (CT_set_data_3d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off, k_off - - if (bc_index <= 0) return - - halo = 0 ; if (present(halo_size)) halo = halo_size - scale = 1.0 ; if (present(scale_factor)) scale = scale_factor - - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var%num_bcs) & - call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var%num_bcs.") - if (field_index > var%bc(bc_index)%num_fields) & - call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - trim(var%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ', & - (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%iec-var%isc) /= (idim(3)-idim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an i-direction computional domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - (1+idim(4)-idim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var%isc) - else - if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ', & - size(array_in,1), ' does not match the data of size ', & - (2*halo + 1 + var%iec - var%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ', & - (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var%jec-var%jsc) /= (jdim(3)-jdim(2))) & - call mpp_error(FATAL, trim(error_header)//" There is an j-direction computional domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo)) & - call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - (1+jdim(4)-jdim(1)), ' is too small to match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var%jsc) - else - if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ', & - size(array_in,2), ' does not match the data of size ', & - (2*halo + 1 + var%jec - var%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var%jsc-halo) - endif - - if (size(array_in,3) /= 1 + var%ke - var%ks) then - write (error_msg, *) trim(error_header), ' The target array with k-dimension size ', & - size(array_in,3), ' does not match the data of size ', & - (1 + var%ke - var%ks) - call mpp_error(FATAL, trim(error_msg)) - endif - k_off = 1 - var%ks - - do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo - var%bc(bc_index)%field(field_index)%values(i,j,k) = scale * array_in(i+i_off,j+j_off,k+k_off) - enddo ; enddo ; enddo - -end subroutine CT_set_data_3d - - -!> This routine registers the diagnostics of a coupler_2d_bc_type. -subroutine CT_set_diags_2d(var, diag_name, axes, time) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 2) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - '(coupler_types_set_diags_3d): axes has less than 2 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name, & - var%bc(n)%field(m)%name, axes(1:2), Time, & - var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units ) - enddo - enddo - -end subroutine CT_set_diags_2d - -!> This routine registers the diagnostics of a coupler_3d_bc_type. -subroutine CT_set_diags_3d(var, diag_name, axes, time) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, - !! then don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 3) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - '(coupler_types_set_diags_3d): axes has less than 3 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name, & - var%bc(n)%field(m)%name, axes(1:3), Time, & - var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units ) - enddo - enddo - -end subroutine CT_set_diags_3d - - -!> This subroutine writes out all diagnostics of elements of a coupler_2d_bc_type -subroutine CT_send_data_2d(var, Time) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_send_data_2d - -!> This subroutine writes out all diagnostics of elements of a coupler_2d_bc_type -subroutine CT_send_data_3d(var, Time) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_send_data_3d - - -!> This subroutine registers the fields in a coupler_2d_bc_type to be saved -!! in restart files specified in the field table. -subroutine CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m - - ocn_rest = .true. ; if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = register_restart_field(bc_rest_files(f), & - rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_2d - -!> This subroutine registers the fields in a coupler_2d_bc_type to be saved -!! in the specified restart file. -subroutine CT_register_restarts_to_file_2d(var, file_name, rest_file, mpp_domain, & - varname_prefix) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = register_restart_field(rest_file, & - file_name, var_name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_to_file_2d - -!> This subroutine registers the fields in a coupler_3d_bc_type to be saved -!! in restart files specified in the field table. -subroutine CT_register_restarts_3d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m, id_restart - - ocn_rest = .true. ; if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = register_restart_field(bc_rest_files(f), & - rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_3d - -!> This subroutine registers the fields in a coupler_3d_bc_type to be saved -!! in the specified restart file. -subroutine CT_register_restarts_to_file_3d(var, file_name, rest_file, mpp_domain, & - varname_prefix) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = register_restart_field(rest_file, & - file_name, var_name, var%bc(n)%field(m)%values, & - mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - -end subroutine CT_register_restarts_to_file_3d - - -!> This subroutine reads in the fields in a coupler_2d_bc_type that have -!! been saved in restart files. -subroutine CT_restore_state_2d(var, directory, all_or_nothing, & - all_required, test_by_field) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. ; all_set = .true. ; num_fld = 0 ; unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. ; all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest, & - directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL, & - "CT_restore_state_2d: test_by_field is true, and "//& - trim(unset_varname)//" was not read but some other fields in "//& - trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL, & - "CT_restore_state_2d: all_or_nothing is true, and "//& - trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then ; if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_2d: all_required is true, but "//& - trim(unset_varname)//" was not read from its restart file.") - endif ; endif - -end subroutine CT_restore_state_2d - -!> This subroutine reads in the fields in a coupler_3d_bc_type that have -!! been saved in restart files. -subroutine CT_restore_state_3d(var, directory, all_or_nothing, & - all_required, test_by_field) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. ; all_set = .true. ; num_fld = 0 ; unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. ; all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest, & - directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL, & - "CT_restore_state_3d: test_by_field is true, and "//& - trim(unset_varname)//" was not read but some other fields in "//& - trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL, & - "CT_restore_state_3d: all_or_nothing is true, and "//& - trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then ; if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_3d: all_required is true, but "//& - trim(unset_varname)//" was not read from its restart file.") - endif ; endif - -end subroutine CT_restore_state_3d - - -!> This subroutine potentially overrides the values in a coupler_2d_bc_type -subroutine CT_data_override_2d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_data_override_2d - -!> This subroutine potentially overrides the values in a coupler_3d_bc_type -subroutine CT_data_override_3d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo ; enddo - -end subroutine CT_data_override_3d - - -!> This subroutine writes out checksums for the elements of a coupler_2d_bc_type -subroutine CT_write_chksums_2d(var, outunit, name_lead) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics - integer, intent(in) :: outunit !< The index of a open output file - character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names - - character(len=120) :: var_name - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') trim(var_name), & - mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec) ) - enddo ; enddo - -end subroutine CT_write_chksums_2d - -!> This subroutine writes out checksums for the elements of a coupler_3d_bc_type -subroutine CT_write_chksums_3d(var, outunit, name_lead) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics - integer, intent(in) :: outunit !< The index of a open output file - character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names - - character(len=120) :: var_name - integer :: m, n - - do n = 1, var%num_bcs ; do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') var_name, & - mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec,:) ) - enddo ; enddo - -end subroutine CT_write_chksums_3d - - -!> This function indicates whether a coupler_1d_bc_type has been initialized. -function CT_initialized_1d(var) - type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_1d !< The return value, indicating whether this type has been initialized - - CT_initialized_1d = var%set -end function CT_initialized_1d - -!> This function indicates whether a coupler_2d_bc_type has been initialized. -function CT_initialized_2d(var) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_2d !< The return value, indicating whether this type has been initialized - - CT_initialized_2d = var%set -end function CT_initialized_2d - -!> This function indicates whether a coupler_3d_bc_type has been initialized. -function CT_initialized_3d(var) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - logical :: CT_initialized_3d !< The return value, indicating whether this type has been initialized - - CT_initialized_3d = var%set -end function CT_initialized_3d - - -!> This subroutine deallocates all data associated with a coupler_1d_bc_type -subroutine CT_destructor_1d(var) - type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_1d - -!> This subroutine deallocates all data associated with a coupler_2d_bc_type -subroutine CT_destructor_2d(var) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_2d - - -!> This subroutine deallocates all data associated with a coupler_3d_bc_type -subroutine CT_destructor_3d(var) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 ; var%set = .false. - -end subroutine CT_destructor_3d - -end module coupler_types_mod diff --git a/config_src/solo_driver/coupler_util.F90 b/config_src/solo_driver/coupler_util.F90 deleted file mode 100644 index cc63a9563d..0000000000 --- a/config_src/solo_driver/coupler_util.F90 +++ /dev/null @@ -1,135 +0,0 @@ -!> Provides a couple of interfaces to allow more transparent and -!! robust extraction of the various fields in the coupler types. -module coupler_util - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use coupler_types_mod, only : coupler_2d_bc_type, ind_flux, ind_alpha -use coupler_types_mod, only : ind_csurf - -implicit none ; private - -public :: extract_coupler_values, set_coupler_values -public :: ind_flux, ind_alpha, ind_csurf - -contains - -!> Extract an array of values in a coupler bc type -subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, & - is, ie, js, je, conversion) - type(coupler_2d_bc_type), intent(in) :: BC_struc !< The type from which the data is being extracted. - integer, intent(in) :: BC_index !< The boundary condition number being extracted. - integer, intent(in) :: BC_element !< The element of the boundary condition being extracted. - real, dimension(:,:), intent(out) :: array_out !< The array being filled with the input values. - integer, optional, intent(in) :: is !< Start i-index - integer, optional, intent(in) :: ie !< End i-index - integer, optional, intent(in) :: js !< Start j-index - integer, optional, intent(in) :: je !< End j-index - real, optional, intent(in) :: conversion !< A number that every element is multiplied by, to - ! Local variables - real, pointer, dimension(:,:) :: Array_in - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"extract_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_in => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_out,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_out,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_out,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_out,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_in,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - if (size(Array_in,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and output array or computational domain.") - i_offset = lbound(Array_in,1) - is0 - j_offset = lbound(Array_in,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - array_out(i,j) = conv * Array_in(i+i_offset,j+j_offset) - enddo ; enddo - -end subroutine extract_coupler_values - -!> Set an array of values in a coupler bc type -subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, & - is, ie, js, je, conversion) - real, dimension(:,:), intent(in) :: array_in !< The array containing the values to load into the BC. - type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type from which the data is being extracted. - integer, intent(in) :: BC_index !< The boundary condition number being extracted. - integer, intent(in) :: BC_element !< The element of the boundary condition being extracted. - integer, optional, intent(in) :: is !< Start i-index - integer, optional, intent(in) :: ie !< End i-index - integer, optional, intent(in) :: js !< Start j-index - integer, optional, intent(in) :: je !< End j-index - real, optional, intent(in) :: conversion !< A number that every element is multiplied by, to - !! permit sign convention or unit conversion. - ! Local variables - real, pointer, dimension(:,:) :: Array_out - real :: conv - integer :: i, j, is0, ie0, js0, je0, i_offset, j_offset - - if ((BC_element /= ind_flux) .and. (BC_element /= ind_alpha) .and. & - (BC_element /= ind_csurf)) then - call MOM_error(FATAL,"extract_coupler_values: Unrecognized BC_element.") - endif - - ! These error messages should be made more explicit. -! if (.not.associated(BC_struc%bc(BC_index))) & - if (.not.associated(BC_struc%bc)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition is not associated.") -! if (.not.associated(BC_struc%bc(BC_index)%field(BC_element))) & - if (.not.associated(BC_struc%bc(BC_index)%field)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition element is not associated.") - if (.not.associated(BC_struc%bc(BC_index)%field(BC_element)%values)) & - call MOM_error(FATAL,"set_coupler_values: " // & - "The requested boundary condition value array is not associated.") - - Array_out => BC_struc%bc(BC_index)%field(BC_element)%values - - if (present(is)) then ; is0 = is ; else ; is0 = LBOUND(array_in,1) ; endif - if (present(ie)) then ; ie0 = ie ; else ; ie0 = UBOUND(array_in,1) ; endif - if (present(js)) then ; js0 = js ; else ; js0 = LBOUND(array_in,2) ; endif - if (present(je)) then ; je0 = je ; else ; je0 = UBOUND(array_in,2) ; endif - - conv = 1.0 ; if (present(conversion)) conv = conversion - - if (size(Array_out,1) /= ie0 - is0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - if (size(Array_out,2) /= je0 - js0 + 1) & - call MOM_error(FATAL,"extract_coupler_values: Mismatch in i-size " // & - "between BC array and input array or computational domain.") - i_offset = lbound(Array_out,1) - is0 - j_offset = lbound(Array_out,2) - js0 - do j=js0,je0 ; do i=is0,ie0 - Array_out(i+i_offset,j+j_offset) = conv * array_in(i,j) - enddo ; enddo - -end subroutine set_coupler_values - -end module coupler_util diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index a9787b9348..5ff39ae8c4 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -256,16 +256,16 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & @@ -273,13 +273,13 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index f6c84dff5a..b9aedb7a1c 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -161,8 +161,8 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "REMAP_UV_USING_OLD_ALG", & CS%remap_uv_using_old_alg, & - "If true, uses the old remapping-via-a-delta-z method for\n"//& - "remapping u and v. If false, uses the new method that remaps\n"//& + "If true, uses the old remapping-via-a-delta-z method for "//& + "remapping u and v. If false, uses the new method that remaps "//& "between grids described by an old and new thickness.", & default=.true.) @@ -171,24 +171,24 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) ! Initialize and configure remapping call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & - "This sets the reconstruction scheme used\n"//& - "for vertical remapping for all variables.\n"//& - "It can be one of the following schemes:\n"//& + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & - "If true, cell-by-cell reconstructions are checked for\n"//& - "consistency and if non-monotonicty or an inconsistency is\n"//& + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.) call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & - "If true, the results of remapping are checked for\n"//& - "conservation and new extrema and if an inconsistency is\n"//& + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.) call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & - "If true, the values on the intermediate grid used for remapping\n"//& - "are forced to be bounded, which might not be the case due to\n"//& + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& "round off.", default=.false.) call get_param(param_file, mdl, "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & - "If true, values at the interfaces of boundary cells are \n"//& + "If true, values at the interfaces of boundary cells are "//& "extrapolated instead of piecewise constant", default=.false.) call initialize_remapping( CS%remapCS, string, & boundary_extrapolation=remap_boundary_extrap, & @@ -197,32 +197,32 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) force_bounds_in_subcell=force_bounds_in_subcell) call get_param(param_file, mdl, "REMAP_AFTER_INITIALIZATION", CS%remap_after_initialization, & - "If true, applies regridding and remapping immediately after\n"//& - "initialization so that the state is ALE consistent. This is a\n"//& - "legacy step and should not be needed if the initialization is\n"//& + "If true, applies regridding and remapping immediately after "//& + "initialization so that the state is ALE consistent. This is a "//& + "legacy step and should not be needed if the initialization is "//& "consistent with the coordinate mode.", default=.true.) call get_param(param_file, mdl, "REGRID_TIME_SCALE", CS%regrid_time_scale, & - "The time-scale used in blending between the current (old) grid\n"//& - "and the target (new) grid. A short time-scale favors the target\n"//& - "grid (0. or anything less than DT_THERM) has no memory of the old\n"//& + "The time-scale used in blending between the current (old) grid "//& + "and the target (new) grid. A short time-scale favors the target "//& + "grid (0. or anything less than DT_THERM) has no memory of the old "//& "grid. A very long time-scale makes the model more Lagrangian.", & units="s", default=0.) call get_param(param_file, mdl, "REGRID_FILTER_SHALLOW_DEPTH", filter_shallow_depth, & - "The depth above which no time-filtering is applied. Above this depth\n"//& + "The depth above which no time-filtering is applied. Above this depth "//& "final grid exactly matches the target (new) grid.", & units="m", default=0., scale=GV%m_to_H) call get_param(param_file, mdl, "REGRID_FILTER_DEEP_DEPTH", filter_deep_depth, & - "The depth below which full time-filtering is applied with time-scale\n"//& - "REGRID_TIME_SCALE. Between depths REGRID_FILTER_SHALLOW_DEPTH and\n"//& - "REGRID_FILTER_SHALLOW_DEPTH the filter wieghts adopt a cubic profile.", & + "The depth below which full time-filtering is applied with time-scale "//& + "REGRID_TIME_SCALE. Between depths REGRID_FILTER_SHALLOW_DEPTH and "//& + "REGRID_FILTER_SHALLOW_DEPTH the filter weights adopt a cubic profile.", & units="m", default=0., scale=GV%m_to_H) call set_regrid_params(CS%regridCS, depth_of_time_filter_shallow=filter_shallow_depth, & depth_of_time_filter_deep=filter_deep_depth) call get_param(param_file, mdl, "REGRID_USE_OLD_DIRECTION", local_logical, & - "If true, the regridding ntegrates upwards from the bottom for\n"//& - "interface positions, much as the main model does. If false\n"//& - "regridding integrates downward, consistant with the remapping\n"//& + "If true, the regridding ntegrates upwards from the bottom for "//& + "interface positions, much as the main model does. If false "//& + "regridding integrates downward, consistant with the remapping "//& "code.", default=.true., do_not_log=.true.) call set_regrid_params(CS%regridCS, integrate_downward_for_e=.not.local_logical) @@ -1121,8 +1121,8 @@ subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS) character(len=30) :: coord_mode call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", coord_mode, & - "Coordinate mode for vertical regridding.\n"//& - "Choose among the following possibilities:\n"//& + "Coordinate mode for vertical regridding. "//& + "Choose among the following possibilities: "//& trim(regriddingCoordinateModeDoc), & default=DEFAULT_COORDINATE_MODE, fail_if_missing=.true.) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 2a1bcd5bcb..bb171aba7a 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -140,8 +140,8 @@ module MOM_regridding !> Documentation for coordinate options character(len=*), parameter, public :: regriddingCoordinateModeDoc = & " LAYER - Isopycnal or stacked shallow water layers\n"//& - " ZSTAR, Z* - stetched geopotential z*\n"//& - " SIGMA_SHELF_ZSTAR - stetched geopotential z* ignoring shelf\n"//& + " ZSTAR, Z* - stretched geopotential z*\n"//& + " SIGMA_SHELF_ZSTAR - stretched geopotential z* ignoring shelf\n"//& " SIGMA - terrain following coordinates\n"//& " RHO - continuous isopycnal\n"//& " HYCOM1 - HyCOM-like hybrid coordinate\n"//& @@ -230,8 +230,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (main_parameters) then ! Read coordinate units parameter (main model = REGRIDDING_COORDINATE_UNITS) call get_param(param_file, mdl, "REGRIDDING_COORDINATE_UNITS", coord_units, & - "Units of the regridding coordinuate.",& !### Spelling error "coordinuate" - default=coordinateUnits(coord_mode)) + "Units of the regridding coordinate.", default=coordinateUnits(coord_mode)) else coord_units=coordinateUnits(coord_mode) endif @@ -245,21 +244,21 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m string2 = 'PPM_H4' ! Default for diagnostics endif call get_param(param_file, mdl, "INTERPOLATION_SCHEME", string, & - "This sets the interpolation scheme to use to\n"//& - "determine the new grid. These parameters are\n"//& - "only relevant when REGRIDDING_COORDINATE_MODE is\n"//& - "set to a function of state. Otherwise, it is not\n"//& - "used. It can be one of the following schemes:\n"//& + "This sets the interpolation scheme to use to "//& + "determine the new grid. These parameters are "//& + "only relevant when REGRIDDING_COORDINATE_MODE is "//& + "set to a function of state. Otherwise, it is not "//& + "used. It can be one of the following schemes: "//& trim(regriddingInterpSchemeDoc), default=trim(string2)) call set_regrid_params(CS, interp_scheme=string) endif if (main_parameters .and. coord_is_state_dependent) then call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", tmpLogical, & - "When defined, a proper high-order reconstruction\n"//& - "scheme is used within boundary cells rather\n"//& - "than PCM. E.g., if PPM is used for remapping, a\n"//& - "PPM reconstruction will also be used within\n"//& + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& + "PPM reconstruction will also be used within "//& "boundary cells.", default=regriddingDefaultBoundaryExtrapolation) call set_regrid_params(CS, boundary_extrapolation=tmpLogical) else @@ -278,7 +277,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (maximum_depth>3000.) string2='WOA09' ! For convenience endif call get_param(param_file, mdl, param_name, string, & - "Determines how to specify the coordinate\n"//& + "Determines how to specify the coordinate "//& "resolution. Valid options are:\n"//& " PARAM - use the vector-parameter "//trim(coord_res_param)//"\n"//& " UNIFORM[:N] - uniformly distributed\n"//& @@ -420,7 +419,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target, & - 'HYBRID target densities for itnerfaces', units=coordinateUnits(coord_mode)) + 'HYBRID target densities for interfaces', units=coordinateUnits(coord_mode)) endif elseif (index(trim(string),'WOA09')==1) then if (len_trim(string)==5) then @@ -502,15 +501,15 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (main_parameters .and. coord_is_state_dependent) then call get_param(param_file, mdl, "REGRID_COMPRESSIBILITY_FRACTION", tmpReal, & - "When interpolating potential density profiles we can add\n"//& - "some artificial compressibility solely to make homogenous\n"//& + "When interpolating potential density profiles we can add "//& + "some artificial compressibility solely to make homogeneous "//& "regions appear stratified.", default=0.) call set_regrid_params(CS, compress_fraction=tmpReal) endif if (main_parameters) then call get_param(param_file, mdl, "MIN_THICKNESS", tmpReal, & - "When regridding, this is the minimum layer\n"//& + "When regridding, this is the minimum layer "//& "thickness allowed.", units="m", scale=GV%m_to_H, & default=regriddingDefaultMinThickness ) call set_regrid_params(CS, min_thickness=tmpReal) @@ -521,23 +520,23 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (coordinateMode(coord_mode) == REGRIDDING_SLIGHT) then ! Set SLight-specific regridding parameters. call get_param(param_file, mdl, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & - "The nominal thickness of fixed thickness near-surface\n"//& + "The nominal thickness of fixed thickness near-surface "//& "layers with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) call get_param(param_file, mdl, "SLIGHT_NZ_SURFACE_FIXED", nz_fixed_sfc, & - "The number of fixed-depth surface layers with the SLight\n"//& + "The number of fixed-depth surface layers with the SLight "//& "coordinate.", units="nondimensional", default=2) call get_param(param_file, mdl, "SLIGHT_SURFACE_AVG_DEPTH", Rho_avg_depth, & - "The thickness of the surface region over which to average\n"//& - "when calculating the density to use to define the interior\n"//& + "The thickness of the surface region over which to average "//& + "when calculating the density to use to define the interior "//& "with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) call get_param(param_file, mdl, "SLIGHT_NLAY_TO_INTERIOR", nlay_sfc_int, & - "The number of layers to offset the surface density when\n"//& + "The number of layers to offset the surface density when "//& "defining where the interior ocean starts with SLight.", & units="nondimensional", default=2.0) call get_param(param_file, mdl, "SLIGHT_FIX_HALOCLINES", fix_haloclines, & - "If true, identify regions above the reference pressure\n"//& - "where the reference pressure systematically underestimates\n"//& - "the stratification and use this in the definition of the\n"//& + "If true, identify regions above the reference pressure "//& + "where the reference pressure systematically underestimates "//& + "the stratification and use this in the definition of the "//& "interior with the SLight coordinate.", default=.false.) call set_regrid_params(CS, dz_min_surface=dz_fixed_sfc, & @@ -546,14 +545,14 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (fix_haloclines) then ! Set additional parameters related to SLIGHT_FIX_HALOCLINES. call get_param(param_file, mdl, "HALOCLINE_FILTER_LENGTH", filt_len, & - "A length scale over which to smooth the temperature and\n"//& + "A length scale over which to smooth the temperature and "//& "salinity before identifying erroneously unstable haloclines.", & units="m", default=2.0) call get_param(param_file, mdl, "HALOCLINE_STRAT_TOL", strat_tol, & - "A tolerance for the ratio of the stratification of the\n"//& - "apparent coordinate stratification to the actual value\n"//& - "that is used to identify erroneously unstable haloclines.\n"//& - "This ratio is 1 when they are equal, and sensible values \n"//& + "A tolerance for the ratio of the stratification of the "//& + "apparent coordinate stratification to the actual value "//& + "that is used to identify erroneously unstable haloclines. "//& + "This ratio is 1 when they are equal, and sensible values "//& "are between 0 and 0.5.", units="nondimensional", default=0.2) call set_regrid_params(CS, halocline_filt_len=filt_len, & halocline_strat_tol=strat_tol) @@ -576,7 +575,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "Scaling on optimization tendency.", & units="nondim", default=1.0) call get_param(param_file, mdl, "ADAPT_DO_MIN_DEPTH", tmpLogical, & - "If true, make a HyCOM-like mixed layer by preventing interfaces\n"//& + "If true, make a HyCOM-like mixed layer by preventing interfaces "//& "from being shallower than the depths specified by the regridding coordinate.", & default=.false.) diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 452b3dfa09..74af5813eb 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -286,7 +286,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ zInterface(1) = 0. do k = 1,nz zInterface(k+1) = zInterface(k) - h1(k) - ! Adjust interface position to accomodate inflating layers + ! Adjust interface position to accommodate inflating layers ! without disturbing the interface above enddo else @@ -294,7 +294,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ zInterface(nz+1) = -depth do k = nz,1,-1 zInterface(k) = zInterface(k+1) + h1(k) - ! Adjust interface position to accomodate inflating layers + ! Adjust interface position to accommodate inflating layers ! without disturbing the interface above enddo endif diff --git a/src/ALE/coord_sigma.F90 b/src/ALE/coord_sigma.F90 index 3bf666ec52..19c3213996 100644 --- a/src/ALE/coord_sigma.F90 +++ b/src/ALE/coord_sigma.F90 @@ -72,7 +72,7 @@ subroutine build_sigma_column(CS, depth, totalThickness, zInterface) zInterface(CS%nk+1) = -depth do k = CS%nk,1,-1 zInterface(k) = zInterface(k+1) + (totalThickness * CS%coordinateResolution(k)) - ! Adjust interface position to accomodate inflating layers + ! Adjust interface position to accommodate inflating layers ! without disturbing the interface above if (zInterface(k) < (zInterface(k+1) + CS%min_thickness)) then zInterface(k) = zInterface(k+1) + CS%min_thickness diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3364943222..301969ed50 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -61,8 +61,6 @@ module MOM use MOM_diagnostics, only : register_surface_diags, write_static_fields use MOM_diagnostics, only : post_surface_dyn_diags, post_surface_thermo_diags use MOM_diagnostics, only : diagnostics_CS, surface_diag_IDs, transport_diag_IDs -use MOM_diag_to_Z, only : calculate_Z_diag_fields, register_Z_tracer -use MOM_diag_to_Z, only : MOM_diag_to_Z_init, MOM_diag_to_Z_end, diag_to_Z_CS use MOM_dynamics_unsplit, only : step_MOM_dyn_unsplit, register_restarts_dyn_unsplit use MOM_dynamics_unsplit, only : initialize_dyn_unsplit, end_dyn_unsplit use MOM_dynamics_unsplit, only : MOM_dyn_unsplit_CS @@ -247,9 +245,6 @@ module MOM type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. - type(time_type) :: Z_diag_interval !< amount of time between calculating Z-space diagnostics - type(time_type) :: Z_diag_time !< next time to compute Z-space diagnostics - real, dimension(:,:,:), pointer :: & h_pre_dyn => NULL(), & !< The thickness before the transports [H ~> m or kg m-2]. T_pre_dyn => NULL(), & !< Temperature before the transports [degC]. @@ -354,8 +349,6 @@ module MOM !< Pointer to the globally summed output control structure type(diagnostics_CS), pointer :: diagnostics_CSp => NULL() !< Pointer to the MOM diagnostics control structure - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() - !< Pointer to the MOM Z-space diagnostics control structure type(offline_transport_CS), pointer :: offline_CSp => NULL() !< Pointer to the offline tracer transport control structure @@ -799,18 +792,6 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call disable_averaging(CS%diag) CS%t_dyn_rel_diag = 0.0 - call cpu_clock_begin(id_clock_Z_diag) - if (Time_local + real_to_time(0.5*dt_therm) > CS%Z_diag_time) then - call enable_averaging(real(time_type_to_real(CS%Z_diag_interval)), & - CS%Z_diag_time, CS%diag) - !### This is the one place where fluxes might used if do_thermo=.false. Is this correct? - call calculate_Z_diag_fields(u, v, h, ssh, fluxes%frac_shelf_h, & - G, GV, US, CS%diag_to_Z_CSp) - CS%Z_diag_time = CS%Z_diag_time + CS%Z_diag_interval - call disable_averaging(CS%diag) - if (showCallTree) call callTree_waypoint("finished calculate_Z_diag_fields (step_MOM)") - endif - call cpu_clock_end(id_clock_Z_diag) call cpu_clock_end(id_clock_diagnostics) ; call cpu_clock_end(id_clock_other) endif @@ -1113,7 +1094,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, h, Time_local) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) call post_transport_diagnostics(G, GV, CS%uhtr, CS%vhtr, h, CS%transport_IDs, & - CS%diag_pre_dyn, CS%diag, CS%t_dyn_rel_adv, CS%diag_to_Z_CSp, CS%tracer_reg) + CS%diag_pre_dyn, CS%diag, CS%t_dyn_rel_adv, CS%tracer_reg) ! Rebuild the remap grids now that we've posted the fields which rely on thicknesses ! from before the dynamics calls call diag_update_remap_grids(CS%diag) @@ -1520,7 +1501,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & count_calls, tracer_flow_CSp) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar - type(param_file_type), intent(out) :: param_file !< structure indicating paramater file to parse + type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse type(directories), intent(out) :: dirs !< structure with directory paths type(MOM_control_struct), pointer :: CS !< pointer set in this routine to MOM control structure type(MOM_restart_CS), pointer :: restart_CSp !< pointer set in this routine to the @@ -1666,86 +1647,86 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif call get_param(param_file, "MOM", "CALC_RHO_FOR_SEA_LEVEL", CS%calc_rho_for_sea_lev, & - "If true, the in-situ density is used to calculate the\n"//& - "effective sea level that is returned to the coupler. If false,\n"//& + "If true, the in-situ density is used to calculate the "//& + "effective sea level that is returned to the coupler. If false, "//& "the Boussinesq parameter RHO_0 is used.", default=.false.) call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, "MOM", "USE_EOS", use_EOS, & - "If true, density is calculated from temperature and \n"//& - "salinity with an equation of state. If USE_EOS is \n"//& + "If true, density is calculated from temperature and "//& + "salinity with an equation of state. If USE_EOS is "//& "true, ENABLE_THERMODYNAMICS must be true as well.", & default=use_temperature) call get_param(param_file, "MOM", "DIABATIC_FIRST", CS%diabatic_first, & - "If true, apply diabatic and thermodynamic processes, \n"//& - "including buoyancy forcing and mass gain or loss, \n"//& + "If true, apply diabatic and thermodynamic processes, "//& + "including buoyancy forcing and mass gain or loss, "//& "before stepping the dynamics forward.", default=.false.) call get_param(param_file, "MOM", "USE_CONTEMP_ABSSAL", use_conT_absS, & - "If true, the prognostics T&S are the conservative temperature \n"//& - "and absolute salinity. Care should be taken to convert them \n"//& - "to potential temperature and practical salinity before \n"//& - "exchanging them with the coupler and/or reporting T&S diagnostics.\n", & + "If true, the prognostics T&S are the conservative temperature "//& + "and absolute salinity. Care should be taken to convert them "//& + "to potential temperature and practical salinity before "//& + "exchanging them with the coupler and/or reporting T&S diagnostics.", & default=.false.) CS%tv%T_is_conT = use_conT_absS ; CS%tv%S_is_absS = use_conT_absS call get_param(param_file, "MOM", "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is \n"//& - "true. This assumes that KD = KDML = 0.0 and that \n"//& - "there is no buoyancy forcing, but makes the model \n"//& + "There are no diapycnal mass fluxes if ADIABATIC is "//& + "true. This assumes that KD = KDML = 0.0 and that "//& + "there is no buoyancy forcing, but makes the model "//& "faster by eliminating subroutine calls.", default=.false.) call get_param(param_file, "MOM", "USE_LEGACY_DIABATIC_DRIVER", CS%use_legacy_diabatic_driver, & - "If true, use a legacy version of the diabatic subroutine. \n"//& + "If true, use a legacy version of the diabatic subroutine. "//& "This is temporary and is needed to avoid change in answers.", & default=.true.) call get_param(param_file, "MOM", "DO_DYNAMICS", CS%do_dynamics, & - "If False, skips the dynamics calls that update u & v, as well as \n"//& - "the gravity wave adjustment to h. This is a fragile feature and \n"//& + "If False, skips the dynamics calls that update u & v, as well as "//& + "the gravity wave adjustment to h. This is a fragile feature and "//& "thus undocumented.", default=.true., do_not_log=.true. ) call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & - "If True, advect temperature and salinity horizontally \n"//& - "If False, T/S are registered for advection.\n"//& - "This is intended only to be used in offline tracer mode \n"//& + "If True, advect temperature and salinity horizontally "//& + "If False, T/S are registered for advection. "//& + "This is intended only to be used in offline tracer mode "//& "and is by default false in that case.", & do_not_log = .true., default=.true. ) if (present(offline_tracer_mode)) then ! Only read this parameter in enabled modes call get_param(param_file, "MOM", "OFFLINE_TRACER_MODE", CS%offline_tracer_mode, & - "If true, barotropic and baroclinic dynamics, thermodynamics\n"//& - "are all bypassed with all the fields necessary to integrate\n"//& - "the tracer advection and diffusion equation are read in from\n"//& - "files stored from a previous integration of the prognostic model.\n"//& + "If true, barotropic and baroclinic dynamics, thermodynamics "//& + "are all bypassed with all the fields necessary to integrate "//& + "the tracer advection and diffusion equation are read in from "//& + "files stored from a previous integration of the prognostic model. "//& "NOTE: This option only used in the ocean_solo_driver.", default=.false.) if (CS%offline_tracer_mode) then call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & - "If True, advect temperature and salinity horizontally\n"//& - "If False, T/S are registered for advection.\n"//& + "If True, advect temperature and salinity horizontally "//& + "If False, T/S are registered for advection. "//& "This is intended only to be used in offline tracer mode."//& "and is by default false in that case", & default=.false. ) endif endif call get_param(param_file, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm, & - "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, "MOM", "BULKMIXEDLAYER", bulkmixedlayer, & - "If true, use a Kraus-Turner-like bulk mixed layer \n"//& - "with transitional buffer layers. Layers 1 through \n"//& - "NKML+NKBL have variable densities. There must be at \n"//& - "least NKML+NKBL+1 layers if BULKMIXEDLAYER is true. \n"//& - "BULKMIXEDLAYER can not be used with USE_REGRIDDING. \n"//& + "If true, use a Kraus-Turner-like bulk mixed layer "//& + "with transitional buffer layers. Layers 1 through "//& + "NKML+NKBL have variable densities. There must be at "//& + "least NKML+NKBL+1 layers if BULKMIXEDLAYER is true. "//& + "BULKMIXEDLAYER can not be used with USE_REGRIDDING. "//& "The default is influenced by ENABLE_THERMODYNAMICS.", & default=use_temperature .and. .not.CS%use_ALE_algorithm) call get_param(param_file, "MOM", "THICKNESSDIFFUSE", CS%thickness_diffuse, & - "If true, interface heights are diffused with a \n"//& + "If true, interface heights are diffused with a "//& "coefficient of KHTH.", default=.false.) call get_param(param_file, "MOM", "THICKNESSDIFFUSE_FIRST", & CS%thickness_diffuse_first, & - "If true, do thickness diffusion before dynamics.\n"//& + "If true, do thickness diffusion before dynamics. "//& "This is only used if THICKNESSDIFFUSE is true.", & default=.false.) if (.not.CS%thickness_diffuse) CS%thickness_diffuse_first = .false. call get_param(param_file, "MOM", "BATHYMETRY_AT_VEL", bathy_at_vel, & - "If true, there are separate values for the basin depths \n"//& - "at velocity points. Otherwise the effects of topography \n"//& + "If true, there are separate values for the basin depths "//& + "at velocity points. Otherwise the effects of topography "//& "are entirely determined from thickness points.", & default=.false.) call get_param(param_file, "MOM", "USE_WAVES", CS%UseWaves, default=.false., & @@ -1755,56 +1736,51 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) call get_param(param_file, "MOM", "DEBUG_TRUNCATIONS", debug_truncations, & - "If true, calculate all diagnostics that are useful for \n"//& + "If true, calculate all diagnostics that are useful for "//& "debugging truncations.", default=.false., debuggingParam=.true.) call get_param(param_file, "MOM", "DT", CS%dt, & - "The (baroclinic) dynamics time step. The time-step that \n"//& - "is actually used will be an integer fraction of the \n"//& - "forcing time-step (DT_FORCING in ocean-only mode or the \n"//& + "The (baroclinic) dynamics time step. The time-step that "//& + "is actually used will be an integer fraction of the "//& + "forcing time-step (DT_FORCING in ocean-only mode or the "//& "coupling timestep in coupled mode.)", units="s", & fail_if_missing=.true.) call get_param(param_file, "MOM", "DT_THERM", CS%dt_therm, & - "The thermodynamic and tracer advection time step. \n"//& - "Ideally DT_THERM should be an integer multiple of DT \n"//& - "and less than the forcing or coupling time-step, unless \n"//& - "THERMO_SPANS_COUPLING is true, in which case DT_THERM \n"//& - "can be an integer multiple of the coupling timestep. By \n"//& + "The thermodynamic and tracer advection time step. "//& + "Ideally DT_THERM should be an integer multiple of DT "//& + "and less than the forcing or coupling time-step, unless "//& + "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& + "can be an integer multiple of the coupling timestep. By "//& "default DT_THERM is set to DT.", units="s", default=CS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", CS%thermo_spans_coupling, & - "If true, the MOM will take thermodynamic and tracer \n"//& - "timesteps that can be longer than the coupling timestep. \n"//& - "The actual thermodynamic timestep that is used in this \n"//& - "case is the largest integer multiple of the coupling \n"//& + "If true, the MOM will take thermodynamic and tracer "//& + "timesteps that can be longer than the coupling timestep. "//& + "The actual thermodynamic timestep that is used in this "//& + "case is the largest integer multiple of the coupling "//& "timestep that is less than or equal to DT_THERM.", default=.false.) if (bulkmixedlayer) then CS%Hmix = -1.0 ; CS%Hmix_UV = -1.0 else call get_param(param_file, "MOM", "HMIX_SFC_PROP", CS%Hmix, & - "If BULKMIXEDLAYER is false, HMIX_SFC_PROP is the depth \n"//& - "over which to average to find surface properties like \n"//& + "If BULKMIXEDLAYER is false, HMIX_SFC_PROP is the depth "//& + "over which to average to find surface properties like "//& "SST and SSS or density (but not surface velocities).", & units="m", default=1.0, scale=US%m_to_Z) call get_param(param_file, "MOM", "HMIX_UV_SFC_PROP", CS%Hmix_UV, & - "If BULKMIXEDLAYER is false, HMIX_UV_SFC_PROP is the depth\n"//& - "over which to average to find surface flow properties,\n"//& + "If BULKMIXEDLAYER is false, HMIX_UV_SFC_PROP is the depth "//& + "over which to average to find surface flow properties, "//& "SSU, SSV. A non-positive value indicates no averaging.", & units="m", default=0.0, scale=US%m_to_Z) endif call get_param(param_file, "MOM", "HFREEZE", CS%HFrz, & - "If HFREEZE > 0, melt potential will be computed. The actual depth \n"//& - "over which melt potential is computed will be min(HFREEZE, OBLD), \n"//& - "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), \n"//& + "If HFREEZE > 0, melt potential will be computed. The actual depth "//& + "over which melt potential is computed will be min(HFREEZE, OBLD), "//& + "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& "melt potential will not be computed.", units="m", default=-1.0) - call get_param(param_file, "MOM", "MIN_Z_DIAG_INTERVAL", Z_diag_int, & - "The minimum amount of time in seconds between \n"//& - "calculations of depth-space diagnostics. Making this \n"//& - "larger than DT_THERM reduces the performance penalty \n"//& - "of regridding to depth online.", units="s", default=0.0) call get_param(param_file, "MOM", "INTERPOLATE_P_SURF", CS%interp_p_surf, & - "If true, linearly interpolate the surface pressure \n"//& - "over the coupling time step, using the specified value \n"//& + "If true, linearly interpolate the surface pressure "//& + "over the coupling time step, using the specified value "//& "at the end of the step.", default=.false.) if (CS%split) then @@ -1812,10 +1788,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & default_val = CS%dt_therm ; if (dtbt > 0.0) default_val = -1.0 CS%dtbt_reset_period = -1.0 call get_param(param_file, "MOM", "DTBT_RESET_PERIOD", CS%dtbt_reset_period, & - "The period between recalculations of DTBT (if DTBT <= 0). \n"//& - "If DTBT_RESET_PERIOD is negative, DTBT is set based \n"//& - "only on information available at initialization. If 0, \n"//& - "DTBT will be set every dynamics time step. The default \n"//& + "The period between recalculations of DTBT (if DTBT <= 0). "//& + "If DTBT_RESET_PERIOD is negative, DTBT is set based "//& + "only on information available at initialization. If 0, "//& + "DTBT will be set every dynamics time step. The default "//& "is set by DT_THERM. This is only used if SPLIT is true.", & units="s", default=default_val, do_not_read=(dtbt > 0.0)) endif @@ -1824,42 +1800,46 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & use_frazil = .false. ; bound_salinity = .false. ; CS%tv%P_Ref = 2.0e7 if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & - "If true, water freezes if it gets too cold, and the \n"//& - "the accumulated heat deficit is returned in the \n"//& - "surface state. FRAZIL is only used if \n"//& + "If true, water freezes if it gets too cold, and the "//& + "the accumulated heat deficit is returned in the "//& + "surface state. FRAZIL is only used if "//& "ENABLE_THERMODYNAMICS is true.", default=.false.) call get_param(param_file, "MOM", "DO_GEOTHERMAL", use_geothermal, & "If true, apply geothermal heating.", default=.false.) call get_param(param_file, "MOM", "BOUND_SALINITY", bound_salinity, & - "If true, limit salinity to being positive. (The sea-ice \n"//& - "model may ask for more salt than is available and \n"//& + "If true, limit salinity to being positive. (The sea-ice "//& + "model may ask for more salt than is available and "//& "drive the salinity negative otherwise.)", default=.false.) + call get_param(param_file, "MOM", "MIN_SALINITY", CS%tv%min_salinity, & + "The minimum value of salinity when BOUND_SALINITY=True. "//& + "The default is 0.01 for backward compatibility but ideally "//& + "should be 0.", units="PPT", default=0.01, do_not_log=.not.bound_salinity) call get_param(param_file, "MOM", "C_P", CS%tv%C_p, & - "The heat capacity of sea water, approximated as a \n"//& - "constant. This is only used if ENABLE_THERMODYNAMICS is \n"//& - "true. The default value is from the TEOS-10 definition \n"//& + "The heat capacity of sea water, approximated as a "//& + "constant. This is only used if ENABLE_THERMODYNAMICS is "//& + "true. The default value is from the TEOS-10 definition "//& "of conservative temperature.", units="J kg-1 K-1", & default=3991.86795711963) endif if (use_EOS) call get_param(param_file, "MOM", "P_REF", CS%tv%P_Ref, & - "The pressure that is used for calculating the coordinate \n"//& - "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) \n"//& - "This is only used if USE_EOS and ENABLE_THERMODYNAMICS \n"//& + "The pressure that is used for calculating the coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS "//& "are true.", units="Pa", default=2.0e7) if (bulkmixedlayer) then call get_param(param_file, "MOM", "NKML", nkml, & - "The number of sublayers within the mixed layer if \n"//& + "The number of sublayers within the mixed layer if "//& "BULKMIXEDLAYER is true.", units="nondim", default=2) call get_param(param_file, "MOM", "NKBL", nkbl, & - "The number of layers that are used as variable density \n"//& + "The number of layers that are used as variable density "//& "buffer layers if BULKMIXEDLAYER is true.", units="nondim", & default=2) endif call get_param(param_file, "MOM", "GLOBAL_INDEXING", global_indexing, & - "If true, use a global lateral indexing convention, so \n"//& - "that corresponding points on different processors have \n"//& + "If true, use a global lateral indexing convention, so "//& + "that corresponding points on different processors have "//& "the same index. This does not work with static memory.", & default=.false., layoutParam=.true.) #ifdef STATIC_MEMORY_ @@ -1867,9 +1847,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "GLOBAL_INDEXING can not be true with STATIC_MEMORY.") #endif call get_param(param_file, "MOM", "FIRST_DIRECTION", first_direction, & - "An integer that indicates which direction goes first \n"//& - "in parts of the code that use directionally split \n"//& - "updates, with even numbers (or 0) used for x- first \n"//& + "An integer that indicates which direction goes first "//& + "in parts of the code that use directionally split "//& + "updates, with even numbers (or 0) used for x- first "//& "and odd numbers used for y-first.", default=0) call get_param(param_file, "MOM", "CHECK_BAD_SURFACE_VALS", CS%check_bad_sfc_vals, & @@ -1877,37 +1857,37 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & default=.false.) if (CS%check_bad_sfc_vals) then call get_param(param_file, "MOM", "BAD_VAL_SSH_MAX", CS%bad_val_ssh_max, & - "The value of SSH above which a bad value message is \n"//& + "The value of SSH above which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & default=20.0) call get_param(param_file, "MOM", "BAD_VAL_SSS_MAX", CS%bad_val_sss_max, & - "The value of SSS above which a bad value message is \n"//& + "The value of SSS above which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="PPT", & default=45.0) call get_param(param_file, "MOM", "BAD_VAL_SST_MAX", CS%bad_val_sst_max, & - "The value of SST above which a bad value message is \n"//& + "The value of SST above which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", & units="deg C", default=45.0) call get_param(param_file, "MOM", "BAD_VAL_SST_MIN", CS%bad_val_sst_min, & - "The value of SST below which a bad value message is \n"//& + "The value of SST below which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", & units="deg C", default=-2.1) call get_param(param_file, "MOM", "BAD_VAL_COLUMN_THICKNESS", CS%bad_val_col_thick, & - "The value of column thickness below which a bad value message is \n"//& + "The value of column thickness below which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & default=0.0) endif call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, & - "If true, write the initial conditions to a file given \n"//& + "If true, write the initial conditions to a file given "//& "by IC_OUTPUT_FILE.", default=.false.) call get_param(param_file, "MOM", "IC_OUTPUT_FILE", CS%IC_file, & "The file into which to write the initial conditions.", & default="MOM_IC") call get_param(param_file, "MOM", "WRITE_GEOM", write_geom, & - "If =0, never write the geometry and vertical grid files.\n"//& - "If =1, write the geometry and vertical grid files only for\n"//& - "a new simulation. If =2, always write the geometry and\n"//& + "If =0, never write the geometry and vertical grid files. "//& + "If =1, write the geometry and vertical grid files only for "//& + "a new simulation. If =2, always write the geometry and "//& "vertical grid files. Other values are invalid.", default=1) if (write_geom<0 .or. write_geom>2) call MOM_error(FATAL,"MOM: "//& "WRITE_GEOM must be equal to 0, 1 or 2.") @@ -1947,9 +1927,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%ensemble_ocean=.false. call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, & - "If False, The model is being run in serial mode as a single realization.\n"//& - "If True, The current model realization is part of a larger ensemble \n"//& - "and at the end of step MOM, we will perform a gather of the ensemble\n"//& + "If False, The model is being run in serial mode as a single realization. "//& + "If True, The current model realization is part of a larger ensemble "//& + "and at the end of step MOM, we will perform a gather of the ensemble "//& "members for statistical evaluation and/or data assimilation.", default=.false.) call callTree_waypoint("MOM parameters read (initialize_MOM)") @@ -2366,11 +2346,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & param_file, diag, CS%diagnostics_CSp, CS%tv) call diag_copy_diag_to_storage(CS%diag_pre_sync, CS%h, CS%diag) - CS%Z_diag_interval = real_to_time(CS%dt_therm * max(1,floor(0.01 + Z_diag_int/CS%dt_therm))) - call MOM_diag_to_Z_init(Time, G, GV, US, param_file, diag, CS%diag_to_Z_CSp) - CS%Z_diag_time = Start_time + CS%Z_diag_interval * (1 + & - ((Time + real_to_time(CS%dt_therm)) - Start_time) / CS%Z_diag_interval) - if (associated(CS%sponge_CSp)) & call init_sponge_diags(Time, G, diag, CS%sponge_CSp) @@ -2379,11 +2354,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (CS%adiabatic) then call adiabatic_driver_init(Time, G, param_file, diag, CS%diabatic_CSp, & - CS%tracer_flow_CSp, CS%diag_to_Z_CSp) + CS%tracer_flow_CSp) else call diabatic_driver_init(Time, G, GV, US, param_file, CS%use_ALE_algorithm, diag, & CS%ADp, CS%CDp, CS%diabatic_CSp, CS%tracer_flow_CSp, & - CS%sponge_CSp, CS%ALE_sponge_CSp, CS%diag_to_Z_CSp) + CS%sponge_CSp, CS%ALE_sponge_CSp) endif call tracer_advect_init(Time, G, param_file, diag, CS%tracer_adv_CSp) @@ -2398,7 +2373,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call register_diags(Time, G, GV, CS%IDs, CS%diag) call register_transport_diags(Time, G, GV, CS%transport_IDs, CS%diag) call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, & - CS%use_ALE_algorithm, CS%diag_to_Z_CSp) + CS%use_ALE_algorithm) if (CS%use_ALE_algorithm) then call ALE_register_diags(Time, G, GV, US, diag, CS%ALE_CSp) endif @@ -2407,7 +2382,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & new_sim = is_new_run(restart_CSp) call tracer_flow_control_init(.not.new_sim, Time, G, GV, US, CS%h, param_file, & CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & - CS%ALE_sponge_CSp, CS%diag_to_Z_CSp, CS%tv) + CS%ALE_sponge_CSp, CS%tv) if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp ! If running in offline tracer mode, initialize the necessary control structure and @@ -2778,10 +2753,10 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%SST(i,j) = CS%tv%T(i,j,1) sfc_state%SSS(i,j) = CS%tv%S(i,j,1) enddo ; enddo ; endif - do j=js,je ; do I=IscB,IecB + do j=js,je ; do I=is-1,ie sfc_state%u(I,j) = u(I,j,1) enddo ; enddo - do J=JscB,JecB ; do i=is,ie + do J=js-1,je ; do i=is,ie sfc_state%v(i,J) = v(i,J,1) enddo ; enddo @@ -2833,12 +2808,15 @@ subroutine extract_surface_state(CS, sfc_state) enddo ! end of j loop ! Determine the mean velocities in the uppermost depth_ml fluid. + ! NOTE: Velocity loops start on `[ij]s-1` in order to update halo values + ! required by the speed diagnostic on the non-symmetric grid. + ! This assumes that u and v halos have already been updated. if (CS%Hmix_UV>0.) then !### This calculation should work in thickness (H) units instead of Z, but that !### would change answers at roundoff in non-Boussinesq cases. depth_ml = CS%Hmix_UV !$OMP parallel do default(shared) private(depth,dh,hv) - do J=jscB,jecB + do J=js-1,ie do i=is,ie depth(i) = 0.0 sfc_state%v(i,J) = 0.0 @@ -2865,11 +2843,11 @@ subroutine extract_surface_state(CS, sfc_state) !$OMP parallel do default(shared) private(depth,dh,hu) do j=js,je - do I=iscB,iecB + do I=is-1,ie depth(I) = 0.0 sfc_state%u(I,j) = 0.0 enddo - do k=1,nz ; do I=iscB,iecB + do k=1,nz ; do I=is-1,ie hu = 0.5 * (h(i,j,k) + h(i+1,j,k)) * GV%H_to_Z if (depth(i) + hu < depth_ml) then dh = hu @@ -2882,17 +2860,17 @@ subroutine extract_surface_state(CS, sfc_state) depth(I) = depth(I) + dh enddo ; enddo ! Calculate the average properties of the mixed layer depth. - do I=iscB,iecB + do I=is-1,ie if (depth(I) < GV%H_subroundoff*GV%H_to_Z) & depth(I) = GV%H_subroundoff*GV%H_to_Z sfc_state%u(I,j) = sfc_state%u(I,j) / depth(I) enddo enddo ! end of j loop else ! Hmix_UV<=0. - do j=js,je ; do I=IscB,IecB + do j=js,je ; do I=is-1,ie sfc_state%u(I,j) = u(I,j,1) enddo ; enddo - do J=JscB,JecB ; do i=is,ie + do J=js-1,je ; do i=is,ie sfc_state%v(i,J) = v(i,J,1) enddo ; enddo endif @@ -3415,7 +3393,7 @@ end subroutine MOM_end !! * src/tracer: !! These files handle the lateral transport and diffusion of !! tracers, or are the code to implement various passive tracer -!! packages. Additional tracer packages are readily accomodated. +!! packages. Additional tracer packages are readily accommodated. !! !! * src/user: !! These are either stub routines that a user could use to change diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 6b4fdd8924..a897e2af13 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -951,23 +951,23 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & - "If true, no slip boundary conditions are used; otherwise \n"//& - "free slip boundary conditions are assumed. The \n"//& - "implementation of the free slip BCs on a C-grid is much \n"//& - "cleaner than the no slip BCs. The use of free slip BCs \n"//& - "is strongly encouraged, and no slip BCs are not used with \n"//& + "If true, no slip boundary conditions are used; otherwise "//& + "free slip boundary conditions are assumed. The "//& + "implementation of the free slip BCs on a C-grid is much "//& + "cleaner than the no slip BCs. The use of free slip BCs "//& + "is strongly encouraged, and no slip BCs are not used with "//& "the biharmonic viscosity.", default=.false.) call get_param(param_file, mdl, "CORIOLIS_EN_DIS", CS%Coriolis_En_Dis, & - "If true, two estimates of the thickness fluxes are used \n"//& - "to estimate the Coriolis term, and the one that \n"//& + "If true, two estimates of the thickness fluxes are used "//& + "to estimate the Coriolis term, and the one that "//& "dissipates energy relative to the other one is used.", & default=.false.) ! Set %Coriolis_Scheme ! (Select the baseline discretization for the Coriolis term) call get_param(param_file, mdl, "CORIOLIS_SCHEME", tmpstr, & - "CORIOLIS_SCHEME selects the discretization for the \n"//& + "CORIOLIS_SCHEME selects the discretization for the "//& "Coriolis terms. Valid values are: \n"//& "\t SADOURNY75_ENERGY - Sadourny, 1975; energy cons. \n"//& "\t ARAKAWA_HSU90 - Arakawa & Hsu, 1990 \n"//& @@ -998,16 +998,16 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) end select if (CS%Coriolis_Scheme == AL_BLEND) then call get_param(param_file, mdl, "CORIOLIS_BLEND_WT_LIN", CS%wt_lin_blend, & - "A weighting value for the ratio of inverse thicknesses, \n"//& - "beyond which the blending between Sadourny Energy and \n"//& - "Arakawa & Hsu goes linearly to 0 when CORIOLIS_SCHEME \n"//& + "A weighting value for the ratio of inverse thicknesses, "//& + "beyond which the blending between Sadourny Energy and "//& + "Arakawa & Hsu goes linearly to 0 when CORIOLIS_SCHEME "//& "is ARAWAKA_LAMB_BLEND. This must be between 1 and 1e-16.", & units="nondim", default=0.125) call get_param(param_file, mdl, "CORIOLIS_BLEND_F_EFF_MAX", CS%F_eff_max_blend, & - "The factor by which the maximum effective Coriolis \n"//& - "acceleration from any point can be increased when \n"//& - "blending different discretizations with the \n"//& - "ARAKAWA_LAMB_BLEND Coriolis scheme. This must be \n"//& + "The factor by which the maximum effective Coriolis "//& + "acceleration from any point can be increased when "//& + "blending different discretizations with the "//& + "ARAKAWA_LAMB_BLEND Coriolis scheme. This must be "//& "greater than 2.0 (the max value for Sadourny energy).", & units="nondim", default=4.0) CS%wt_lin_blend = min(1.0, max(CS%wt_lin_blend,1e-16)) @@ -1015,16 +1015,16 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) "CORIOLIS_BLEND_F_EFF_MAX should be at least 2.") endif - mesg = "If true, the Coriolis terms at u-points are bounded by \n"//& - "the four estimates of (f+rv)v from the four neighboring \n"//& + mesg = "If true, the Coriolis terms at u-points are bounded by "//& + "the four estimates of (f+rv)v from the four neighboring "//& "v-points, and similarly at v-points." if (CS%Coriolis_En_Dis .and. (CS%Coriolis_Scheme == SADOURNY75_ENERGY)) then - mesg = trim(mesg)//" This option is \n"//& - "always effectively false with CORIOLIS_EN_DIS defined and \n"//& + mesg = trim(mesg)//" This option is "//& + "always effectively false with CORIOLIS_EN_DIS defined and "//& "CORIOLIS_SCHEME set to "//trim(SADOURNY75_ENERGY_STRING)//"." else - mesg = trim(mesg)//" This option would \n"//& - "have no effect on the SADOURNY Coriolis scheme if it \n"//& + mesg = trim(mesg)//" This option would "//& + "have no effect on the SADOURNY Coriolis scheme if it "//& "were possible to use centered difference thickness fluxes." endif call get_param(param_file, mdl, "BOUND_CORIOLIS", CS%bound_Coriolis, mesg, & @@ -1034,7 +1034,7 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) ! Set KE_Scheme (selects discretization of KE) call get_param(param_file, mdl, "KE_SCHEME", tmpstr, & - "KE_SCHEME selects the discretization for acceleration \n"//& + "KE_SCHEME selects the discretization for acceleration "//& "due to the kinetic energy gradient. Valid values are: \n"//& "\t KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV", & default=KE_ARAKAWA_STRING) @@ -1051,7 +1051,7 @@ subroutine CoriolisAdv_init(Time, G, param_file, diag, AD, CS) ! Set PV_Adv_Scheme (selects discretization of PV advection) call get_param(param_file, mdl, "PV_ADV_SCHEME", tmpstr, & - "PV_ADV_SCHEME selects the discretization for PV \n"//& + "PV_ADV_SCHEME selects the discretization for PV "//& "advection. Valid values are: \n"//& "\t PV_ADV_CENTERED - centered (aka Sadourny, 75) \n"//& "\t PV_ADV_UPWIND1 - upwind, first order", & diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 110963789b..183817bf42 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -117,13 +117,13 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ANALYTIC_FV_PGF", CS%Analytic_FV_PGF, & - "If true the pressure gradient forces are calculated \n"//& - "with a finite volume form that analytically integrates \n"//& - "the equations of state in pressure to avoid any \n"//& - "possibility of numerical thermobaric instability, as \n"//& + "If true the pressure gradient forces are calculated "//& + "with a finite volume form that analytically integrates "//& + "the equations of state in pressure to avoid any "//& + "possibility of numerical thermobaric instability, as "//& "described in Adcroft et al., O. Mod. (2008).", default=.true.) call get_param(param_file, mdl, "BLOCKED_ANALYTIC_FV_PGF", CS%blocked_AFV, & - "If true, used the blocked version of the ANALYTIC_FV_PGF \n"//& + "If true, used the blocked version of the ANALYTIC_FV_PGF "//& "code. The value of this parameter should not change answers.", & default=.false., do_not_log=.true., debuggingParam=.true.) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 09d3e64266..42c08b8364 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -842,9 +842,9 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ mdl = "MOM_PressureForce_Mont" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "TIDES", CS%tides, & diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index a8fcae3596..e68a699b7a 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -810,36 +810,36 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C mdl = "MOM_PressureForce_AFV" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & - "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & - "If true, use mass weighting when interpolating T/S for\n"//& - "integrals near the bathymetry in AFV pressure gradient\n"//& + "If true, use mass weighting when interpolating T/S for "//& + "integrals near the bathymetry in AFV pressure gradient "//& "calculations.", default=.false.) call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & - "If True, use vertical reconstruction of T & S within\n"//& - "the integrals of the FV pressure gradient calculation.\n"//& - "If False, use the constant-by-layer algorithm.\n"//& + "If True, use vertical reconstruction of T & S within "//& + "the integrals of the FV pressure gradient calculation. "//& + "If False, use the constant-by-layer algorithm. "//& "The default is set by USE_REGRIDDING.", & default=use_ALE ) call get_param(param_file, mdl, "PRESSURE_RECONSTRUCTION_SCHEME", CS%Recon_Scheme, & - "Order of vertical reconstruction of T/S to use in the\n"//& - "integrals within the FV pressure gradient calculation."//& + "Order of vertical reconstruction of T/S to use in the "//& + "integrals within the FV pressure gradient calculation.\n"//& " 0: PCM or no reconstruction.\n"//& " 1: PLM reconstruction.\n"//& " 2: PPM reconstruction.", default=1) call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", CS%boundary_extrap, & - "If true, the reconstruction of T & S for pressure in \n"//& - "boundary cells is extrapolated, rather than using PCM \n"//& - "in these cells. If true, the same order polynomial is \n"//& + "If true, the reconstruction of T & S for pressure in "//& + "boundary cells is extrapolated, rather than using PCM "//& + "in these cells. If true, the same order polynomial is "//& "used as is used for the interior cells.", default=.true.) if (CS%tides) then diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index a675eebaf4..4b602373e7 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -802,36 +802,36 @@ subroutine PressureForce_blk_AFV_init(Time, G, GV, US, param_file, diag, CS, tid mdl = "MOM_PressureForce_blk_AFV" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & - "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & - "If true, use mass weighting when interpolating T/S for\n"//& - "integrals near the bathymetry in AFV pressure gradient\n"//& + "If true, use mass weighting when interpolating T/S for "//& + "integrals near the bathymetry in AFV pressure gradient "//& "calculations.", default=.false.) call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & - "If True, use vertical reconstruction of T & S within\n"//& - "the integrals of the FV pressure gradient calculation.\n"//& - "If False, use the constant-by-layer algorithm.\n"//& + "If True, use vertical reconstruction of T & S within "//& + "the integrals of the FV pressure gradient calculation. "//& + "If False, use the constant-by-layer algorithm. "//& "The default is set by USE_REGRIDDING.", & default=use_ALE ) call get_param(param_file, mdl, "PRESSURE_RECONSTRUCTION_SCHEME", CS%Recon_Scheme, & - "Order of vertical reconstruction of T/S to use in the\n"//& - "integrals within the FV pressure gradient calculation."//& + "Order of vertical reconstruction of T/S to use in the "//& + "integrals within the FV pressure gradient calculation.\n"//& " 0: PCM or no reconstruction.\n"//& " 1: PLM reconstruction.\n"//& " 2: PPM reconstruction.", default=1) call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", CS%boundary_extrap, & - "If true, the reconstruction of T & S for pressure in \n"//& - "boundary cells is extrapolated, rather than using PCM \n"//& - "in these cells. If true, the same order polynomial is \n"//& + "If true, the reconstruction of T & S for pressure in "//& + "boundary cells is extrapolated, rather than using PCM "//& + "in these cells. If true, the same order polynomial is "//& "used as is used for the interior cells.", default=.true.) if (CS%tides) then diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index e09570b23d..33450e8a3d 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -199,7 +199,7 @@ module MOM_barotropic !! update at the start of a call to btstep. The !! default is 1. logical :: BT_project_velocity !< If true, step the barotropic velocity first - !! and project out the velocity tendancy by 1+BEBT + !! and project out the velocity tendency by 1+BEBT !! when calculating the transport. The default !! (false) is to use a predictor continuity step to !! find the pressure field, and then do a corrector @@ -3779,32 +3779,32 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, if (.not.CS%split) return call get_param(param_file, mdl, "BOUND_BT_CORRECTION", CS%bound_BT_corr, & - "If true, the corrective pseudo mass-fluxes into the \n"//& - "barotropic solver are limited to values that require \n"//& + "If true, the corrective pseudo mass-fluxes into the "//& + "barotropic solver are limited to values that require "//& "less than maxCFL_BT_cont to be accommodated.",default=.false.) call get_param(param_file, mdl, "BT_CONT_CORR_BOUNDS", CS%BT_cont_bounds, & - "If true, and BOUND_BT_CORRECTION is true, use the \n"//& - "BT_cont_type variables to set limits determined by \n"//& - "MAXCFL_BT_CONT on the CFL number of the velocites \n"//& + "If true, and BOUND_BT_CORRECTION is true, use the "//& + "BT_cont_type variables to set limits determined by "//& + "MAXCFL_BT_CONT on the CFL number of the velocities "//& "that are likely to be driven by the corrective mass fluxes.", & default=.true.) !, do_not_log=.not.CS%bound_BT_corr) call get_param(param_file, mdl, "ADJUST_BT_CONT", CS%adjust_BT_cont, & - "If true, adjust the curve fit to the BT_cont type \n"//& - "that is used by the barotropic solver to match the \n"//& + "If true, adjust the curve fit to the BT_cont type "//& + "that is used by the barotropic solver to match the "//& "transport about which the flow is being linearized.", default=.false.) call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & - "If true, adjust the initial conditions for the \n"//& - "barotropic solver to the values from the layered \n"//& - "solution over a whole timestep instead of instantly. \n"//& - "This is a decent approximation to the inclusion of \n"//& + "If true, adjust the initial conditions for the "//& + "barotropic solver to the values from the layered "//& + "solution over a whole timestep instead of instantly. "//& + "This is a decent approximation to the inclusion of "//& "sum(u dh_dt) while also correcting for truncation errors.", & default=.false.) call get_param(param_file, mdl, "BT_USE_VISC_REM_U_UH0", CS%visc_rem_u_uh0, & - "If true, use the viscous remnants when estimating the \n"//& - "barotropic velocities that were used to calculate uh0 \n"//& + "If true, use the viscous remnants when estimating the "//& + "barotropic velocities that were used to calculate uh0 "//& "and vh0. False is probably the better choice.", default=.false.) call get_param(param_file, mdl, "BT_USE_WIDE_HALOS", CS%use_wide_halos, & - "If true, use wide halos and march in during the \n"//& + "If true, use wide halos and march in during the "//& "barotropic time stepping for efficiency.", default=.true., & layoutParam=.true.) call get_param(param_file, mdl, "BTHALO", bt_halo_sz, & @@ -3812,7 +3812,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, layoutParam=.true.) #ifdef STATIC_MEMORY_ if ((bt_halo_sz > 0) .and. (bt_halo_sz /= BTHALO_)) call MOM_error(FATAL, & - "barotropic_init: Run-time values of BTHALO must agree with the \n"//& + "barotropic_init: Run-time values of BTHALO must agree with the "//& "macro BTHALO_ with STATIC_MEMORY_.") wd_halos(1) = WHALOI_+NIHALO_ ; wd_halos(2) = WHALOJ_+NJHALO_ #else @@ -3826,65 +3826,65 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, layoutParam=.true.) call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & - "If true, use a structure with elements that describe \n"//& - "effective face areas from the summed continuity solver \n"//& - "as a function the barotropic flow in coupling between \n"//& - "the barotropic and baroclinic flow. This is only used \n"//& + "If true, use a structure with elements that describe "//& + "effective face areas from the summed continuity solver "//& + "as a function the barotropic flow in coupling between "//& + "the barotropic and baroclinic flow. This is only used "//& "if SPLIT is true. \n", default=.true.) call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", & CS%Nonlinear_continuity, & - "If true, use nonlinear transports in the barotropic \n"//& - "continuity equation. This does not apply if \n"//& + "If true, use nonlinear transports in the barotropic "//& + "continuity equation. This does not apply if "//& "USE_BT_CONT_TYPE is true.", default=.false.) CS%Nonlin_cont_update_period = 1 if (CS%Nonlinear_continuity) & call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", & CS%Nonlin_cont_update_period, & - "If NONLINEAR_BT_CONTINUITY is true, this is the number \n"//& - "of barotropic time steps between updates to the face \n"//& + "If NONLINEAR_BT_CONTINUITY is true, this is the number "//& + "of barotropic time steps between updates to the face "//& "areas, or 0 to update only before the barotropic stepping.",& units="nondim", default=1) call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", CS%BT_project_velocity,& - "If true, step the barotropic velocity first and project \n"//& - "out the velocity tendancy by 1+BEBT when calculating the \n"//& - "transport. The default (false) is to use a predictor \n"//& - "continuity step to find the pressure field, and then \n"//& - "to do a corrector continuity step using a weighted \n"//& - "average of the old and new velocities, with weights \n"//& + "If true, step the barotropic velocity first and project "//& + "out the velocity tendency by 1+BEBT when calculating the "//& + "transport. The default (false) is to use a predictor "//& + "continuity step to find the pressure field, and then "//& + "to do a corrector continuity step using a weighted "//& + "average of the old and new velocities, with weights "//& "of (1-BEBT) and BEBT.", default=.false.) call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & - "If true, add a dynamic pressure due to a viscous ice \n"//& + "If true, add a dynamic pressure due to a viscous ice "//& "shelf, for instance.", default=.false.) if (CS%dynamic_psurf) then call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & - "The length scale at which the Rayleigh damping rate due \n"//& - "to the ice strength should be the same as if a Laplacian \n"//& + "The length scale at which the Rayleigh damping rate due "//& + "to the ice strength should be the same as if a Laplacian "//& "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", & units="m", default=1.0e4) call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", CS%Dmin_dyn_psurf, & - "The minimum depth to use in limiting the size of the \n"//& - "dynamic surface pressure for stability, if \n"//& + "The minimum depth to use in limiting the size of the "//& + "dynamic surface pressure for stability, if "//& "DYNAMIC_SURFACE_PRESSURE is true..", units="m", & default=1.0e-6) call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & - "The constant that scales the dynamic surface pressure, \n"//& - "if DYNAMIC_SURFACE_PRESSURE is true. Stable values \n"//& + "The constant that scales the dynamic surface pressure, "//& + "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//& "are < ~1.0.", units="nondim", default=0.9) endif call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & - "If true, the Coriolis terms are discretized with the \n"//& - "Sadourny (1975) energy conserving scheme, otherwise \n"//& - "the Arakawa & Hsu scheme is used. If the internal \n"//& - "deformation radius is not resolved, the Sadourny scheme \n"//& + "If true, the Coriolis terms are discretized with the "//& + "Sadourny (1975) energy conserving scheme, otherwise "//& + "the Arakawa & Hsu scheme is used. If the internal "//& + "deformation radius is not resolved, the Sadourny scheme "//& "should probably be used.", default=.true.) call get_param(param_file, mdl, "BT_THICK_SCHEME", hvel_str, & - "A string describing the scheme that is used to set the \n"//& - "open face areas used for barotropic transport and the \n"//& + "A string describing the scheme that is used to set the "//& + "open face areas used for barotropic transport and the "//& "relative weights of the accelerations. Valid values are:\n"//& "\t ARITHMETIC - arithmetic mean layer thicknesses \n"//& "\t HARMONIC - harmonic mean layer thicknesses \n"//& @@ -3910,63 +3910,63 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "can only be used if USE_BT_CONT_TYPE is defined.") call get_param(param_file, mdl, "BT_STRONG_DRAG", CS%strong_drag, & - "If true, use a stronger estimate of the retarding \n"//& - "effects of strong bottom drag, by making it implicit \n"//& - "with the barotropic time-step instead of implicit with \n"//& - "the baroclinic time-step and dividing by the number of \n"//& + "If true, use a stronger estimate of the retarding "//& + "effects of strong bottom drag, by making it implicit "//& + "with the barotropic time-step instead of implicit with "//& + "the baroclinic time-step and dividing by the number of "//& "barotropic steps.", default=.false.) call get_param(param_file, mdl, "BT_LINEAR_WAVE_DRAG", CS%linear_wave_drag, & - "If true, apply a linear drag to the barotropic velocities, \n"//& - "using rates set by lin_drag_u & _vdivided by the depth of \n"//& + "If true, apply a linear drag to the barotropic velocities, "//& + "using rates set by lin_drag_u & _v divided by the depth of "//& "the ocean. This was introduced to facilitate tide modeling.", & default=.false.) call get_param(param_file, mdl, "BT_WAVE_DRAG_FILE", wave_drag_file, & - "The name of the file with the barotropic linear wave drag \n"//& + "The name of the file with the barotropic linear wave drag "//& "piston velocities.", default="", do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "BT_WAVE_DRAG_VAR", wave_drag_var, & - "The name of the variable in BT_WAVE_DRAG_FILE with the \n"//& + "The name of the variable in BT_WAVE_DRAG_FILE with the "//& "barotropic linear wave drag piston velocities at h points.", & default="rH", do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "BT_WAVE_DRAG_SCALE", wave_drag_scale, & - "A scaling factor for the barotropic linear wave drag \n"//& + "A scaling factor for the barotropic linear wave drag "//& "piston velocities.", default=1.0, units="nondim", & do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "CLIP_BT_VELOCITY", CS%clip_velocity, & - "If true, limit any velocity components that exceed \n"//& - "CFL_TRUNCATE. This should only be used as a desperate \n"//& + "If true, limit any velocity components that exceed "//& + "CFL_TRUNCATE. This should only be used as a desperate "//& "debugging measure.", default=.false.) call get_param(param_file, mdl, "CFL_TRUNCATE", CS%CFL_trunc, & - "The value of the CFL number that will cause velocity \n"//& + "The value of the CFL number that will cause velocity "//& "components to be truncated; instability can occur past 0.5.", & units="nondim", default=0.5, do_not_log=.not.CS%clip_velocity) call get_param(param_file, mdl, "MAXVEL", CS%maxvel, & - "The maximum velocity allowed before the velocity \n"//& + "The maximum velocity allowed before the velocity "//& "components are truncated.", units="m s-1", default=3.0e8, & do_not_log=.not.CS%clip_velocity) call get_param(param_file, mdl, "MAXCFL_BT_CONT", CS%maxCFL_BT_cont, & - "The maximum permitted CFL number associated with the \n"//& - "barotropic accelerations from the summed velocities \n"//& + "The maximum permitted CFL number associated with the "//& + "barotropic accelerations from the summed velocities "//& "times the time-derivatives of thicknesses.", units="nondim", & default=0.25) call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & - "A negligibly small velocity magnitude below which velocity \n"//& - "components are set to 0. A reasonable value might be \n"//& - "1e-30 m/s, which is less than an Angstrom divided by \n"//& + "A negligibly small velocity magnitude below which velocity "//& + "components are set to 0. A reasonable value might be "//& + "1e-30 m/s, which is less than an Angstrom divided by "//& "the age of the universe.", units="m s-1", default=0.0) call get_param(param_file, mdl, "DT_BT_FILTER", CS%dt_bt_filter, & - "A time-scale over which the barotropic mode solutions \n"//& - "are filtered, in seconds if positive, or as a fraction \n"//& - "of DT if negative. When used this can never be taken to \n"//& + "A time-scale over which the barotropic mode solutions "//& + "are filtered, in seconds if positive, or as a fraction "//& + "of DT if negative. When used this can never be taken to "//& "be longer than 2*dt. Set this to 0 to apply no filtering.", & units="sec or nondim", default=-0.25) call get_param(param_file, mdl, "G_BT_EXTRA", CS%G_extra, & "A nondimensional factor by which gtot is enhanced.", & units="nondim", default=0.0) call get_param(param_file, mdl, "SSH_EXTRA", SSH_extra, & - "An estimate of how much higher SSH might get, for use \n"//& - "in calculating the safe external wave speed. The \n"//& + "An estimate of how much higher SSH might get, for use "//& + "in calculating the safe external wave speed. The "//& "default is the minimum of 10 m or 5% of MAXIMUM_DEPTH.", & units="m", default=min(10.0,0.05*G%max_depth*US%Z_to_m), scale=US%m_to_Z) @@ -3974,33 +3974,33 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_BT", CS%debug_bt, & - "If true, write out verbose debugging data within the \n"//& - "barotropic time-stepping loop. The data volume can be \n"//& + "If true, write out verbose debugging data within the "//& + "barotropic time-stepping loop. The data volume can be "//& "quite large if this is true.", default=CS%debug, & debuggingParam=.true.) CS%linearized_BT_PV = .true. call get_param(param_file, mdl, "BEBT", CS%bebt, & - "BEBT determines whether the barotropic time stepping \n"//& - "uses the forward-backward time-stepping scheme or a \n"//& - "backward Euler scheme. BEBT is valid in the range from \n"//& - "0 (for a forward-backward treatment of nonrotating \n"//& - "gravity waves) to 1 (for a backward Euler treatment). \n"//& + "BEBT determines whether the barotropic time stepping "//& + "uses the forward-backward time-stepping scheme or a "//& + "backward Euler scheme. BEBT is valid in the range from "//& + "0 (for a forward-backward treatment of nonrotating "//& + "gravity waves) to 1 (for a backward Euler treatment). "//& "In practice, BEBT must be greater than about 0.05.", & units="nondim", default=0.1) call get_param(param_file, mdl, "DTBT", dtbt_input, & - "The barotropic time step, in s. DTBT is only used with \n"//& - "the split explicit time stepping. To set the time step \n"//& - "automatically based the maximum stable value use 0, or \n"//& - "a negative value gives the fraction of the stable value. \n"//& - "Setting DTBT to 0 is the same as setting it to -0.98. \n"//& - "The value of DTBT that will actually be used is an \n"//& + "The barotropic time step, in s. DTBT is only used with "//& + "the split explicit time stepping. To set the time step "//& + "automatically based the maximum stable value use 0, or "//& + "a negative value gives the fraction of the stable value. "//& + "Setting DTBT to 0 is the same as setting it to -0.98. "//& + "The value of DTBT that will actually be used is an "//& "integer fraction of DT, rounding down.", units="s or nondim",& default = -0.98) call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", & CS%use_old_coriolis_bracket_bug , & - "If True, use an order of operations that is not bitwise\n"//& - "rotationally symmetric in the meridional Coriolis term of\n"//& + "If True, use an order of operations that is not bitwise "//& + "rotationally symmetric in the meridional Coriolis term of "//& "the barotropic solver.", default=.false.) ! Initialize a version of the MOM domain that is specific to the barotropic solver. @@ -4404,7 +4404,7 @@ subroutine barotropic_end(CS) end subroutine barotropic_end !> This subroutine is used to register any fields from MOM_barotropic.F90 -!!! that should be written to or read from the restart file. +!! that should be written to or read from the restart file. subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index cf4dc09897..ce69c9816c 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -148,7 +148,7 @@ subroutine continuity_init(Time, G, GV, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "CONTINUITY_SCHEME", tmpstr, & - "CONTINUITY_SCHEME selects the discretization for the \n"//& + "CONTINUITY_SCHEME selects the discretization for the "//& "continuity solver. The only valid value currently is: \n"//& "\t PPM - use a positive-definite (or monotonic) \n"//& "\t piecewise parabolic reconstruction solver.", & diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 3f6b699b20..4cf410160b 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -2258,66 +2258,66 @@ subroutine continuity_PPM_init(Time, G, GV, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MONOTONIC_CONTINUITY", CS%monotonic, & - "If true, CONTINUITY_PPM uses the Colella and Woodward \n"//& - "monotonic limiter. The default (false) is to use a \n"//& + "If true, CONTINUITY_PPM uses the Colella and Woodward "//& + "monotonic limiter. The default (false) is to use a "//& "simple positive definite limiter.", default=.false.) call get_param(param_file, mdl, "SIMPLE_2ND_PPM_CONTINUITY", CS%simple_2nd, & - "If true, CONTINUITY_PPM uses a simple 2nd order \n"//& - "(arithmetic mean) interpolation of the edge values. \n"//& - "This may give better PV conservation propterties. While \n"//& - "it formally reduces the accuracy of the continuity \n"//& - "solver itself in the strongly advective limit, it does \n"//& - "not reduce the overall order of accuracy of the dynamic \n"//& + "If true, CONTINUITY_PPM uses a simple 2nd order "//& + "(arithmetic mean) interpolation of the edge values. "//& + "This may give better PV conservation properties. While "//& + "it formally reduces the accuracy of the continuity "//& + "solver itself in the strongly advective limit, it does "//& + "not reduce the overall order of accuracy of the dynamic "//& "core.", default=.false.) call get_param(param_file, mdl, "UPWIND_1ST_CONTINUITY", CS%upwind_1st, & - "If true, CONTINUITY_PPM becomes a 1st-order upwind \n"//& - "continuity solver. This scheme is highly diffusive \n"//& - "but may be useful for debugging or in single-column \n"//& + "If true, CONTINUITY_PPM becomes a 1st-order upwind "//& + "continuity solver. This scheme is highly diffusive "//& + "but may be useful for debugging or in single-column "//& "mode where its minimal stencil is useful.", default=.false.) call get_param(param_file, mdl, "ETA_TOLERANCE", CS%tol_eta, & - "The tolerance for the differences between the \n"//& - "barotropic and baroclinic estimates of the sea surface \n"//& - "height due to the fluxes through each face. The total \n"//& - "tolerance for SSH is 4 times this value. The default \n"//& - "is 0.5*NK*ANGSTROM, and this should not be set less x\n"//& + "The tolerance for the differences between the "//& + "barotropic and baroclinic estimates of the sea surface "//& + "height due to the fluxes through each face. The total "//& + "tolerance for SSH is 4 times this value. The default "//& + "is 0.5*NK*ANGSTROM, and this should not be set less "//& "than about 10^-15*MAXIMUM_DEPTH.", units="m", scale=GV%m_to_H, & default=0.5*G%ke*GV%Angstrom_m, unscaled=tol_eta_m) call get_param(param_file, mdl, "ETA_TOLERANCE_AUX", CS%tol_eta_aux, & - "The tolerance for free-surface height discrepancies \n"//& - "between the barotropic solution and the sum of the \n"//& - "layer thicknesses when calculating the auxiliary \n"//& - "corrected velocities. By default, this is the same as \n"//& + "The tolerance for free-surface height discrepancies "//& + "between the barotropic solution and the sum of the "//& + "layer thicknesses when calculating the auxiliary "//& + "corrected velocities. By default, this is the same as "//& "ETA_TOLERANCE, but can be made larger for efficiency.", & units="m", default=tol_eta_m, scale=GV%m_to_H) call get_param(param_file, mdl, "VELOCITY_TOLERANCE", CS%tol_vel, & - "The tolerance for barotropic velocity discrepancies \n"//& - "between the barotropic solution and the sum of the \n"//& + "The tolerance for barotropic velocity discrepancies "//& + "between the barotropic solution and the sum of the "//& "layer thicknesses.", units="m s-1", default=3.0e8) ! The speed of light is the default. call get_param(param_file, mdl, "CONT_PPM_AGGRESS_ADJUST", CS%aggress_adjust,& - "If true, allow the adjusted velocities to have a \n"//& + "If true, allow the adjusted velocities to have a "//& "relative CFL change up to 0.5.", default=.false.) CS%vol_CFL = CS%aggress_adjust call get_param(param_file, mdl, "CONT_PPM_VOLUME_BASED_CFL", CS%vol_CFL, & - "If true, use the ratio of the open face lengths to the \n"//& - "tracer cell areas when estimating CFL numbers. The \n"//& + "If true, use the ratio of the open face lengths to the "//& + "tracer cell areas when estimating CFL numbers. The "//& "default is set by CONT_PPM_AGGRESS_ADJUST.", & default=CS%aggress_adjust, do_not_read=CS%aggress_adjust) call get_param(param_file, mdl, "CONTINUITY_CFL_LIMIT", CS%CFL_limit_adjust, & "The maximum CFL of the adjusted velocities.", units="nondim", & default=0.5) call get_param(param_file, mdl, "CONT_PPM_BETTER_ITER", CS%better_iter, & - "If true, stop corrective iterations using a velocity \n"//& - "based criterion and only stop if the iteration is \n"//& + "If true, stop corrective iterations using a velocity "//& + "based criterion and only stop if the iteration is "//& "better than all predecessors.", default=.true.) call get_param(param_file, mdl, "CONT_PPM_USE_VISC_REM_MAX", & CS%use_visc_rem_max, & - "If true, use more appropriate limiting bounds for \n"//& + "If true, use more appropriate limiting bounds for "//& "corrections in strongly viscous columns.", default=.true.) call get_param(param_file, mdl, "CONT_PPM_MARGINAL_FACE_AREAS", CS%marginal_faces, & - "If true, use the marginal face areas from the continuity \n"//& - "solver for use as the weights in the barotropic solver. \n"//& + "If true, use the marginal face areas from the continuity "//& + "solver for use as the weights in the barotropic solver. "//& "Otherwise use the transport averaged areas.", default=.true.) CS%diag => diag diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 2422ac7028..c6bc7b5c6a 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1037,28 +1037,28 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "BE", CS%be, & - "If SPLIT is true, BE determines the relative weighting \n"//& - "of a 2nd-order Runga-Kutta baroclinic time stepping \n"//& - "scheme (0.5) and a backward Euler scheme (1) that is \n"//& - "used for the Coriolis and inertial terms. BE may be \n"//& - "from 0.5 to 1, but instability may occur near 0.5. \n"//& - "BE is also applicable if SPLIT is false and USE_RK2 \n"//& + "If SPLIT is true, BE determines the relative weighting "//& + "of a 2nd-order Runga-Kutta baroclinic time stepping "//& + "scheme (0.5) and a backward Euler scheme (1) that is "//& + "used for the Coriolis and inertial terms. BE may be "//& + "from 0.5 to 1, but instability may occur near 0.5. "//& + "BE is also applicable if SPLIT is false and USE_RK2 "//& "is true.", units="nondim", default=0.6) call get_param(param_file, mdl, "BEGW", CS%begw, & - "If SPLIT is true, BEGW is a number from 0 to 1 that \n"//& - "controls the extent to which the treatment of gravity \n"//& - "waves is forward-backward (0) or simulated backward \n"//& - "Euler (1). 0 is almost always used.\n"//& - "If SPLIT is false and USE_RK2 is true, BEGW can be \n"//& + "If SPLIT is true, BEGW is a number from 0 to 1 that "//& + "controls the extent to which the treatment of gravity "//& + "waves is forward-backward (0) or simulated backward "//& + "Euler (1). 0 is almost always used. "//& + "If SPLIT is false and USE_RK2 is true, BEGW can be "//& "between 0 and 0.5 to damp gravity waves.", & units="nondim", default=0.0) call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, & - "If true, provide the bottom stress calculated by the \n"//& + "If true, provide the bottom stress calculated by the "//& "vertical viscosity to the barotropic solver.", default=.false.) call get_param(param_file, mdl, "BT_USE_LAYER_FLUXES", CS%BT_use_layer_fluxes, & - "If true, use the summed layered fluxes plus an \n"//& - "adjustment due to the change in the barotropic velocity \n"//& + "If true, use the summed layered fluxes plus an "//& + "adjustment due to the change in the barotropic velocity "//& "in the barotropic continuity equation.", default=.true.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 2cb22b12fe..b5b547b362 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -576,19 +576,19 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag CS%diag => diag call get_param(param_file, mdl, "BE", CS%be, & - "If SPLIT is true, BE determines the relative weighting \n"//& - "of a 2nd-order Runga-Kutta baroclinic time stepping \n"//& - "scheme (0.5) and a backward Euler scheme (1) that is \n"//& - "used for the Coriolis and inertial terms. BE may be \n"//& - "from 0.5 to 1, but instability may occur near 0.5. \n"//& - "BE is also applicable if SPLIT is false and USE_RK2 \n"//& + "If SPLIT is true, BE determines the relative weighting "//& + "of a 2nd-order Runga-Kutta baroclinic time stepping "//& + "scheme (0.5) and a backward Euler scheme (1) that is "//& + "used for the Coriolis and inertial terms. BE may be "//& + "from 0.5 to 1, but instability may occur near 0.5. "//& + "BE is also applicable if SPLIT is false and USE_RK2 "//& "is true.", units="nondim", default=0.6) call get_param(param_file, mdl, "BEGW", CS%begw, & - "If SPLIT is true, BEGW is a number from 0 to 1 that \n"//& - "controls the extent to which the treatment of gravity \n"//& - "waves is forward-backward (0) or simulated backward \n"//& - "Euler (1). 0 is almost always used.\n"//& - "If SPLIT is false and USE_RK2 is true, BEGW can be \n"//& + "If SPLIT is true, BEGW is a number from 0 to 1 that "//& + "controls the extent to which the treatment of gravity "//& + "waves is forward-backward (0) or simulated backward "//& + "Euler (1). 0 is almost always used. "//& + "If SPLIT is false and USE_RK2 is true, BEGW can be "//& "between 0 and 0.5 to damp gravity waves.", & units="nondim", default=0.0) call get_param(param_file, mdl, "DEBUG", CS%debug, & diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 465cdf2c28..515697c09e 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2239,10 +2239,19 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_net_massout > 0 .or. handles%id_total_net_massout > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if (fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) - if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) - if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) - if (fluxes%seaice_melt(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) + if (associated(fluxes%lprec)) then + if (fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + endif + if (associated(fluxes%vprec)) then + if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + endif + if (associated(fluxes%evap)) then + if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + endif + if (associated(fluxes%seaice_melt)) then + if (fluxes%seaice_melt(i,j) < 0.0) & + res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) + endif enddo ; enddo if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) if (handles%id_total_net_massout > 0) then @@ -2251,16 +2260,34 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) endif endif - if (handles%id_massout_flux > 0) call post_data(handles%id_massout_flux,fluxes%netMassOut,diag) + if (handles%id_massout_flux > 0 .and. associated(fluxes%netMassOut)) & + call post_data(handles%id_massout_flux,fluxes%netMassOut,diag) if (handles%id_net_massin > 0 .or. handles%id_total_net_massin > 0) then do j=js,je ; do i=is,ie - res(i,j) = fluxes%fprec(i,j) + fluxes%lrunoff(i,j) + fluxes%frunoff(i,j) - if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) - if (fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + res(i,j) = 0.0 + + if (associated(fluxes%fprec)) & + res(i,j) = res(i,j) + fluxes%fprec(i,j) + if (associated(fluxes%lrunoff)) & + res(i,j) = res(i,j) + fluxes%lrunoff(i,j) + if (associated(fluxes%frunoff)) & + res(i,j) = res(i,j) + fluxes%frunoff(i,j) + + if (associated(fluxes%lprec)) then + if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + endif + if (associated(fluxes%vprec)) then + if (fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + endif ! fluxes%cond is not needed because it is derived from %evap > 0 - if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) - if (fluxes%seaice_melt(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) + if (associated(fluxes%evap)) then + if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + endif + if (associated(fluxes%seaice_melt)) then + if (fluxes%seaice_melt(i,j) > 0.0) & + res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) + endif enddo ; enddo if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) if (handles%id_total_net_massin > 0) then @@ -2269,7 +2296,8 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) endif endif - if (handles%id_massin_flux > 0) call post_data(handles%id_massin_flux,fluxes%netMassIn,diag) + if (handles%id_massin_flux > 0 .and. associated(fluxes%netMassIn)) & + call post_data(handles%id_massin_flux,fluxes%netMassIn,diag) if ((handles%id_evap > 0) .and. associated(fluxes%evap)) & call post_data(handles%id_evap, fluxes%evap, diag) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c59eafc4c2..5624167170 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -305,8 +305,9 @@ subroutine open_boundary_config(G, US, param_file, OBC) real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries allocate(OBC) - call log_version(param_file, mdl, version, "Controls where open boundaries are located, what "//& - "kind of boundary condition to impose, and what data to apply, if any.") + call log_version(param_file, mdl, version, & + "Controls where open boundaries are located, what kind of boundary condition "//& + "to impose, and what data to apply, if any.") call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & "The number of open boundary segments.", & default=0) @@ -314,7 +315,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "OBC_USER_CONFIG", config1, & - "A string that sets how the open boundary conditions are \n"//& + "A string that sets how the open boundary conditions are "//& " configured: \n", default="none", do_not_log=.true.) call get_param(param_file, mdl, "NK", OBC%ke, & "The number of model layers", default=0, do_not_log=.true.) @@ -326,16 +327,16 @@ subroutine open_boundary_config(G, US, param_file, OBC) "If true, sets relative vorticity to zero on open boundaries.", & default=.false.) call get_param(param_file, mdl, "OBC_FREESLIP_VORTICITY", OBC%freeslip_vorticity, & - "If true, sets the normal gradient of tangential velocity to\n"// & - "zero in the relative vorticity on open boundaries. This cannot\n"// & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the relative vorticity on open boundaries. This cannot "//& "be true if another OBC_XXX_VORTICITY option is True.", default=.true.) call get_param(param_file, mdl, "OBC_COMPUTED_VORTICITY", OBC%computed_vorticity, & - "If true, uses the external values of tangential velocity\n"// & - "in the relative vorticity on open boundaries. This cannot\n"// & + "If true, uses the external values of tangential velocity "//& + "in the relative vorticity on open boundaries. This cannot "//& "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) call get_param(param_file, mdl, "OBC_SPECIFIED_VORTICITY", OBC%specified_vorticity, & - "If true, uses the external values of tangential velocity\n"// & - "in the relative vorticity on open boundaries. This cannot\n"// & + "If true, uses the external values of tangential velocity "//& + "in the relative vorticity on open boundaries. This cannot "//& "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) if ((OBC%zero_vorticity .and. OBC%freeslip_vorticity) .or. & (OBC%zero_vorticity .and. OBC%computed_vorticity) .or. & @@ -350,16 +351,16 @@ subroutine open_boundary_config(G, US, param_file, OBC) "If true, sets the strain used in the stress tensor to zero on open boundaries.", & default=.false.) call get_param(param_file, mdl, "OBC_FREESLIP_STRAIN", OBC%freeslip_strain, & - "If true, sets the normal gradient of tangential velocity to\n"// & - "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the strain use in the stress tensor on open boundaries. This cannot "//& "be true if another OBC_XXX_STRAIN option is True.", default=.true.) call get_param(param_file, mdl, "OBC_COMPUTED_STRAIN", OBC%computed_strain, & - "If true, sets the normal gradient of tangential velocity to\n"// & - "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the strain use in the stress tensor on open boundaries. This cannot "//& "be true if another OBC_XXX_STRAIN option is True.", default=.false.) call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN", OBC%specified_strain, & - "If true, sets the normal gradient of tangential velocity to\n"// & - "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & + "If true, sets the normal gradient of tangential velocity to "//& + "zero in the strain use in the stress tensor on open boundaries. This cannot "//& "be true if another OBC_XXX_STRAIN option is True.", default=.false.) if ((OBC%zero_strain .and. OBC%freeslip_strain) .or. & (OBC%zero_strain .and. OBC%computed_strain) .or. & @@ -367,11 +368,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) (OBC%freeslip_strain .and. OBC%computed_strain) .or. & (OBC%freeslip_strain .and. OBC%specified_strain) .or. & (OBC%computed_strain .and. OBC%specified_strain)) & - call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& - "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN\n"//& + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: \n"//& + "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//& "and OBC_IMPORTED_STRAIN can be True at once.") call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, & - "If true, zeros the Laplacian of flow on open boundaries in the biharmonic\n"//& + "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//& "viscosity term.", default=.false.) call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & "If true, set the areas outside open boundaries to be land.", & @@ -381,16 +382,16 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=.false.) if (debug_OBC .or. debug) & call log_param(param_file, mdl, "DEBUG_OBC", debug_OBC, & - "If true, do additional calls to help debug the performance \n"//& + "If true, do additional calls to help debug the performance "//& "of the open boundary condition code.", default=.false., & debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & - "A silly value of thicknesses used outside of open boundary \n"//& + "A silly value of thicknesses used outside of open boundary "//& "conditions for debugging.", units="m", default=0.0, & do_not_log=.not.debug_OBC, debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & - "A silly value of velocities used outside of open boundary \n"//& + "A silly value of velocities used outside of open boundary "//& "conditions for debugging.", units="m/s", default=0.0, & do_not_log=.not.debug_OBC, debuggingParam=.true.) reentrant_x = .false. @@ -448,15 +449,15 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & - "The maximum magnitude of the baroclinic radiation \n"//& - "velocity (or speed of characteristics). This is only \n"//& + "The maximum magnitude of the baroclinic radiation "//& + "velocity (or speed of characteristics). This is only "//& "used if one of the open boundary segments is using Orlanski.", & units="m s-1", default=10.0) call get_param(param_file, mdl, "OBC_RAD_VEL_WT", OBC%gamma_uv, & - "The relative weighting for the baroclinic radiation \n"//& - "velocities (or speed of characteristics) at the new \n"//& - "time level (1) or the running mean (0) for velocities. \n"//& - "Valid values range from 0 to 1. This is only used if \n"//& + "The relative weighting for the baroclinic radiation "//& + "velocities (or speed of characteristics) at the new "//& + "time level (1) or the running mean (0) for velocities. "//& + "Valid values range from 0 to 1. This is only used if "//& "one of the open boundary segments is using Orlanski.", & units="nondim", default=0.3) endif @@ -465,13 +466,13 @@ subroutine open_boundary_config(G, US, param_file, OBC) Lscale_out = 0. if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & - "An effective length scale for restoring the tracer concentration \n"//& - "at the boundaries to externally imposed values when the flow \n"//& + "An effective length scale for restoring the tracer concentration "//& + "at the boundaries to externally imposed values when the flow "//& "is exiting the domain.", units="m", default=0.0) call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & - "An effective length scale for restoring the tracer concentration \n"//& - "at the boundaries to values from the interior when the flow \n"//& + "An effective length scale for restoring the tracer concentration "//& + "at the boundaries to values from the interior when the flow "//& "is entering the domain.", units="m", default=0.0) endif @@ -546,21 +547,21 @@ subroutine initialize_segment_data(G, OBC, PF) inputdir = slasher(inputdir) call get_param(PF, mdl, "REMAPPING_SCHEME", remappingScheme, & - "This sets the reconstruction scheme used\n"//& - "for vertical remapping for all variables.\n"//& - "It can be one of the following schemes:\n"//& + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: \n"//& trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) call get_param(PF, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & - "If true, cell-by-cell reconstructions are checked for\n"//& - "consistency and if non-monotonicity or an inconsistency is\n"//& + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) call get_param(PF, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & - "If true, the results of remapping are checked for\n"//& - "conservation and new extrema and if an inconsistency is\n"//& + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) call get_param(PF, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & - "If true, the values on the intermediate grid used for remapping\n"//& - "are forced to be bounded, which might not be the case due to\n"//& + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& "round off.", default=.false.,do_not_log=.true.) call get_param(PF, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & "If true, read external OBC data on the supergrid.", & @@ -862,8 +863,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment,\n"//& - "for inflow, then outflow. Setting both to zero should\n"//& + "Timescales in days for nudging along a segment, "//& + "for inflow, then outflow. Setting both to zero should "//& "behave like SIMPLE obcs for the baroclinic velocities.", & fail_if_missing=.true.,default=0.,units="days") OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. @@ -891,7 +892,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) & - call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc:\n"//& + call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc: \n"//& "Orlanski and Oblique OBC options cannot be used together on one segment.") end subroutine setup_u_point_obc @@ -986,8 +987,8 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment,\n"//& - "for inflow, then outflow. Setting both to zero should\n"//& + "Timescales in days for nudging along a segment, "//& + "for inflow, then outflow. Setting both to zero should "//& "behave like SIMPLE obcs for the baroclinic velocities.", & fail_if_missing=.true.,default=0.,units="days") OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. @@ -1015,7 +1016,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) & - call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc:\n"//& + call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: \n"//& "Orlanski and Oblique OBC options cannot be used together on one segment.") end subroutine setup_v_point_obc diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index c623848c15..3748684fd4 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -80,7 +80,7 @@ module MOM_variables !> Pointers to an assortment of thermodynamic fields that may be available, including !! potential temperature, salinity, heat capacity, and the equation of state control structure. type, public :: thermo_var_ptrs -! If allocated, the following variables have nz layers. + ! If allocated, the following variables have nz layers. real, pointer :: T(:,:,:) => NULL() !< Potential temperature [degC]. real, pointer :: S(:,:,:) => NULL() !< Salnity [PSU] or [gSalt/kg], generically [ppt]. type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the @@ -95,14 +95,16 @@ module MOM_variables !! actually the conservative temperature [degC]. logical :: S_is_absS = .false. !< If true, the salinity variable tv%S is !! actually the absolute salinity in units of [gSalt/kg]. -! These arrays are accumulated fluxes for communication with other components. + real :: min_salinity = 0.01 !< The minimum value of salinity when BOUND_SALINITY=True [ppt]. + !! The default is 0.01 for backward compatibility but should be 0. + ! These arrays are accumulated fluxes for communication with other components. real, dimension(:,:), pointer :: frazil => NULL() !< The energy needed to heat the ocean column to the !! freezing point since calculate_surface_state was2 !! last called [J m-2]. real, dimension(:,:), pointer :: salt_deficit => NULL() !< The salt needed to maintain the ocean column - !! at a minumum salinity of 0.01 PSU since the last time + !! at a minimum salinity of MIN_SALINITY since the last time !! that calculate_surface_state was called, [gSalt m-2]. real, dimension(:,:), pointer :: TempxPmE => NULL() !< The net inflow of water into the ocean times the @@ -206,7 +208,8 @@ module MOM_variables ustar_BBL => NULL() !< The turbulence velocity in the bottom boundary layer at h points [Z s-1 ~> m s-1]. real, pointer, dimension(:,:) :: TKE_BBL => NULL() !< A term related to the bottom boundary layer source of turbulent kinetic - !! energy, currently in [m3 s-3], but will later be changed to [W m-2]. + !! energy, currently in [Z3 T-3 ~> m3 s-3], but may at some time be changed + !! to [kg Z3 m-3 T-3 ~> W m-2]. real, pointer, dimension(:,:) :: & taux_shelf => NULL(), & !< The zonal stresses on the ocean under shelves [Pa]. tauy_shelf => NULL() !< The meridional stresses on the ocean under shelves [Pa]. diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index a824553a84..83fb6d9268 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -50,7 +50,7 @@ module MOM_verticalGrid g_prime, & !< The reduced gravity at each interface [m2 Z-1 s-2 ~> m s-2]. Rlay !< The target coordinate value (potential density) in each layer [kg m-3]. integer :: nkml = 0 !< The number of layers at the top that should be treated - !! as parts of a homogenous region. + !! as parts of a homogeneous region. integer :: nk_rho_varies = 0 !< The number of layers at the top where the !! density does not track any target density. real :: H_to_kg_m2 !< A constant that translates thicknesses from the units of thickness to kg m-2. @@ -92,18 +92,18 @@ subroutine verticalGridInit( param_file, GV, US ) "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "RHO_0", GV%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "BOUSSINESQ", GV%Boussinesq, & "If true, make the Boussinesq approximation.", default=.true.) call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_m, & - "The minumum layer thickness, usually one-Angstrom.", & + "The minimum layer thickness, usually one-Angstrom.", & units="m", default=1.0e-10) call get_param(param_file, mdl, "H_RESCALE_POWER", H_power, & - "An integer power of 2 that is used to rescale the model's \n"//& + "An integer power of 2 that is used to rescale the model's "//& "intenal units of thickness. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) if (abs(H_power) > 300) call MOM_error(FATAL, "verticalGridInit: "//& @@ -112,13 +112,13 @@ subroutine verticalGridInit( param_file, GV, US ) if (H_power /= 0) H_rescale_factor = 2.0**H_power if (.not.GV%Boussinesq) then call get_param(param_file, mdl, "H_TO_KG_M2", GV%H_to_kg_m2,& - "A constant that translates thicknesses from the model's \n"//& + "A constant that translates thicknesses from the model's "//& "internal units of thickness to kg m-2.", units="kg m-2 H-1", & default=1.0) GV%H_to_kg_m2 = GV%H_to_kg_m2 * H_rescale_factor else call get_param(param_file, mdl, "H_TO_M", GV%H_to_m, & - "A constant that translates the model's internal \n"//& + "A constant that translates the model's internal "//& "units of thickness into m.", units="m H-1", default=1.0) GV%H_to_m = GV%H_to_m * H_rescale_factor endif diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index a642cd0205..9c2f0b6adf 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -758,17 +758,17 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & - "The absolute path to the file where the accelerations \n"//& + "The absolute path to the file where the accelerations "//& "leading to zonal velocity truncations are written. \n"//& - "Leave this empty for efficiency if this diagnostic is \n"//& + "Leave this empty for efficiency if this diagnostic is "//& "not needed.", default="", debuggingParam=.true.) call get_param(param_file, mdl, "V_TRUNC_FILE", CS%v_trunc_file, & - "The absolute path to the file where the accelerations \n"//& + "The absolute path to the file where the accelerations "//& "leading to meridional velocity truncations are written. \n"//& - "Leave this empty for efficiency if this diagnostic is \n"//& + "Leave this empty for efficiency if this diagnostic is "//& "not needed.", default="", debuggingParam=.true.) call get_param(param_file, mdl, "MAX_TRUNC_FILE_SIZE_PER_PE", CS%max_writes, & - "The maximum number of colums of truncations that any PE \n"//& + "The maximum number of colums of truncations that any PE "//& "will write out during a run.", default=50, debuggingParam=.true.) if (len_trim(dirs%output_directory) > 0) then diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 79a56cae2f..d4d267d50d 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -88,11 +88,11 @@ subroutine MOM_debugging_init(param_file) "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_CHKSUMS", debug_chksums, & - "If true, checksums are performed on arrays in the \n"//& + "If true, checksums are performed on arrays in the "//& "various vec_chksum routines.", default=debug, & debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_REDUNDANT", debug_redundant, & - "If true, debug redundant data points during calls to \n"//& + "If true, debug redundant data points during calls to "//& "the various vec_chksum routines.", default=debug, & debuggingParam=.true.) diff --git a/src/diagnostics/MOM_diag_to_Z.F90 b/src/diagnostics/MOM_diag_to_Z.F90 deleted file mode 100644 index 3c50f00061..0000000000 --- a/src/diagnostics/MOM_diag_to_Z.F90 +++ /dev/null @@ -1,1351 +0,0 @@ -!> Maps tracers and velocities into depth space for output as diagnostic quantities. -!! -!! Currently, a piecewise linear subgrid structure is used for tracers, while velocities can -!! use either piecewise constant or piecewise linear structures. -module MOM_diag_to_Z - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_coms, only : reproducing_sum -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr -use MOM_diag_mediator, only : diag_ctrl, time_type, diag_axis_init -use MOM_diag_mediator, only : axes_grp, define_axes_group -use MOM_diag_mediator, only : ocean_register_diag -use MOM_domains, only : pass_var -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, query_vardesc, modify_vardesc -use MOM_spatial_means, only : global_layer_mean -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : p3d, p2d -use MOM_verticalGrid, only : verticalGrid_type - -use netcdf - -implicit none ; private - -#include - -public calculate_Z_diag_fields -public register_Z_tracer -public MOM_diag_to_Z_init -public calculate_Z_transport -public MOM_diag_to_Z_end -public ocean_register_diag_with_z -public find_overlap -public find_limited_slope -public register_Zint_diag -public calc_Zint_diags - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - -!> The control structure for the MOM_diag_to_Z module -type, public :: diag_to_Z_CS ; private - ! The following arrays are used to store diagnostics calculated in this - ! module and unavailable outside of it. - - real, pointer, dimension(:,:,:) :: & - u_z => NULL(), & !< zonal velocity remapped to depth space [m s-1] - v_z => NULL(), & !< meridional velocity remapped to depth space [m s-1] - uh_z => NULL(), & !< zonal transport remapped to depth space [H m2 s-1 ~> m3 s-1 or kg s-1] - vh_z => NULL() !< meridional transport remapped to depth space [H m2 s-1 ~> m3 s-1 or kg s-1] - - type(p3d) :: tr_z(MAX_FIELDS_) !< array of tracers, remapped to depth space - type(p3d) :: tr_model(MAX_FIELDS_) !< pointers to an array of tracers - - real :: missing_vel = -1.0e34 !< Missing variable fill values for velocities - real :: missing_trans = -1.0e34 !< Missing variable fill values for transports - real :: missing_tr(MAX_FIELDS_) = -1.0e34 !< Missing variable fill values for tracers - real :: missing_value = -1.0e34 !< Missing variable fill values for other diagnostics - - integer :: id_u_z = -1 !< Diagnostic ID for zonal velocity - integer :: id_v_z = -1 !< Diagnostic ID for meridional velocity - integer :: id_uh_Z = -1 !< Diagnostic ID for zonal transports - integer :: id_vh_Z = -1 !< Diagnostic ID for meridional transports - integer :: id_tr(MAX_FIELDS_) = -1 !< Diagnostic IDs for tracers - integer :: id_tr_xyave(MAX_FIELDS_) = -1 !< Diagnostic IDs for spatially averaged tracers - - integer :: num_tr_used = 0 !< Th enumber of tracers in use. - integer :: nk_zspace = -1 !< The number of levels in the z-space output - - real, pointer :: Z_int(:) => NULL() !< interface depths of the z-space file [Z ~> m]. - - !>@{ Axis groups for z-space diagnostic output - type(axes_grp) :: axesBz, axesTz, axesCuz, axesCvz - type(axes_grp) :: axesBzi, axesTzi, axesCuzi, axesCvzi - type(axes_grp) :: axesZ - !!@} - integer, dimension(1) :: axesz_out - - type(diag_ctrl), pointer :: diag => NULL() ! A structure that is used to - ! regulate the timing of diagnostic output. - -end type diag_to_Z_CS - -integer, parameter :: NO_ZSPACE = -1 !< Flag to enable z-space? - -contains - -!> Return the global horizontal mean in z-space -function global_z_mean(var, G, GV, US, CS, tracer) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(diag_to_Z_CS), pointer :: CS !< Control structure returned by - !! previous call to diag_to_Z_init. - real, dimension(SZI_(G), SZJ_(G), CS%nk_zspace), & - intent(in) :: var !< An array with the variable to average - integer, intent(in) :: tracer !< The tracer index being worked on - ! Local variables - real, dimension(SZI_(G), SZJ_(G), CS%nk_zspace) :: tmpForSumming, weight - real, dimension(CS%nk_zspace) :: global_z_mean, scalarij, weightij - real, dimension(CS%nk_zspace) :: global_temp_scalar, global_weight_scalar - real :: valid_point, depth_weight - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - nz = CS%nk_zspace - - ! Initialize local arrays - tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. - - do k=1,nz ; do j=js,je ; do i=is,ie - valid_point = 1.0 - ! Weight factor for partial bottom cells - depth_weight = min( max(-G%bathyT(i,j), CS%Z_int(k+1)) - CS%Z_int(k), 0.) - - ! Flag the point as invalid if it contains missing data, or is below the bathymetry - if (var(i,j,k) == CS%missing_tr(tracer)) valid_point = 0. - if (depth_weight == 0.) valid_point = 0. - - weight(i,j,k) = US%Z_to_m * depth_weight * ( (valid_point * (G%areaT(i,j) * G%mask2dT(i,j))) ) - - ! If the point is flagged, set the variable itself to zero to avoid NaNs - if (valid_point == 0.) then - tmpForSumming(i,j,k) = 0.0 - else - tmpForSumming(i,j,k) = var(i,j,k) * weight(i,j,k) - endif - enddo ; enddo ; enddo - - global_temp_scalar = reproducing_sum(tmpForSumming, sums=scalarij) - global_weight_scalar = reproducing_sum(weight, sums=weightij) - - do k=1, nz - if (scalarij(k) == 0) then - global_z_mean(k) = 0.0 - else - global_z_mean(k) = scalarij(k) / weightij(k) - endif - enddo - -end function global_z_mean - -!> This subroutine maps tracers and velocities into depth space for diagnostics. -subroutine calculate_Z_diag_fields(u, v, h, ssh_in, frac_shelf_h, G, GV, US, CS) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity [m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity [m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: ssh_in !< Sea surface height in meters. - real, dimension(:,:), pointer :: frac_shelf_h !< The fraction of the cell area covered by - !! ice shelf, or unassocatiaed if there is no shelf - type(diag_to_Z_CS), pointer :: CS !< Control structure returned by a previous call - !! to diag_to_Z_init. - ! Local variables - ! Note the deliberately reversed axes in h_f, u_f, v_f, and tr_f. - real :: ssh(SZI_(G),SZJ_(G)) ! copy of ssh_in whose halos can be updated [H ~> m or kg m-2] - real :: e(SZK_(G)+2) ! z-star interface heights [Z ~> m]. - real :: h_f(SZK_(G)+1,SZI_(G)) ! thicknesses of massive layers [H ~> m or kg m-2] - real :: u_f(SZK_(G)+1,SZIB_(G))! zonal velocity component in any massive layer - real :: v_f(SZK_(G)+1,SZI_(G)) ! meridional velocity component in any massive layer - - real :: tr_f(SZK_(G),max(CS%num_tr_used,1),SZI_(G)) ! tracer concentration in massive layers - integer :: nk_valid(SZIB_(G)) ! number of massive layers in a column - - real :: D_pt(SZIB_(G)) ! bottom depth [Z ~> m]. - real :: shelf_depth(SZIB_(G)) ! ice shelf depth [Z ~> m]. - real :: htot ! summed layer thicknesses [H ~> m or kg m-2] - real :: dilate ! proportion by which to dilate every layer - real :: wt(SZK_(G)+1) ! fractional weight for each layer in the - ! range between k_top and k_bot [nondim] - real :: z1(SZK_(G)+1) ! z1 and z2 are the depths of the top and bottom - real :: z2(SZK_(G)+1) ! limits of the part of a layer that contributes - ! to a depth level, relative to the cell center - ! and normalized by the cell thickness [nondim] - ! Note that -1/2 <= z1 < z2 <= 1/2. - real :: sl_tr(max(CS%num_tr_used,1)) ! normalized slope of the tracer - ! within the cell, in tracer units - real :: Angstrom ! A minimal layer thickness [H ~> m or kg m-2]. - real :: slope ! normalized slope of a variable within the cell - - real :: layer_ave(CS%nk_zspace) - - logical :: linear_velocity_profiles, ice_shelf - - integer :: k_top, k_bot, k_bot_prev - integer :: i, j, k, k2, kz, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nk, m, nkml - integer :: IsgB, IegB, JsgB, JegB - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nk = G%ke - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - IsgB = G%IsgB ; IegB = G%IegB ; JsgB = G%JsgB ; JegB = G%JegB - nkml = max(GV%nkml, 1) - Angstrom = GV%Angstrom_H - linear_velocity_profiles = .true. - - - if (.not.associated(CS)) call MOM_error(FATAL, & - "diagnostic_fields_zstar: Module must be initialized before it is used.") - - ice_shelf = associated(frac_shelf_h) - - ! Update the halos - if (ice_shelf) then - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; ssh(i,j) = US%m_to_Z*ssh_in(i,j) ; enddo ; enddo - call pass_var(ssh, G%Domain) - endif - - ! If no fields are needed, return - if ((CS%id_u_z <= 0) .and. (CS%id_v_z <= 0) .and. (CS%num_tr_used < 1)) return - - ! zonal velocity component - if (CS%id_u_z > 0) then - - do kz=1,CS%nk_zspace ; do j=js,je ; do I=Isq,Ieq - CS%u_z(I,j,kz) = CS%missing_vel - enddo ; enddo ; enddo - - - do j=js,je - shelf_depth(:) = 0. ! initially all is open ocean - ! Remove all massless layers. - do I=Isq,Ieq - nk_valid(I) = 0 - D_pt(I) = 0.5*(G%bathyT(i+1,j)+G%bathyT(i,j)) - if (ice_shelf) then - if (frac_shelf_h(i,j)+frac_shelf_h(i+1,j) > 0.) then ! under shelf - shelf_depth(I) = abs(0.5*(ssh(i+1,j)+ssh(i,j))) - endif - endif - enddo - do k=1,nk ; do I=Isq,Ieq - if ((G%mask2dCu(I,j) > 0.5) .and. (h(i,j,k)+h(i+1,j,k) > 4.0*Angstrom)) then - nk_valid(I) = nk_valid(I) + 1 ; k2 = nk_valid(I) - h_f(k2,I) = 0.5*(h(i,j,k)+h(i+1,j,k)) ; u_f(k2,I) = u(I,j,k) - endif - enddo ; enddo - do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.5) then - ! Add an Angstrom thick layer at the bottom with 0 velocity to impose a - ! no-slip BBC in the output, if anything but piecewise constant is used. - nk_valid(I) = nk_valid(I) + 1 ; k2 = nk_valid(I) - h_f(k2,I) = Angstrom ; u_f(k2,I) = 0.0 - ! GM: D_pt is always slightly larger (by 1E-6 or so) than shelf_depth, so - ! I consider that the ice shelf is grounded for diagnostic purposes when - ! shelf_depth(I) + 1.0E-3*US%m_to_Z > D_pt(i) - if (ice_shelf .and. (shelf_depth(I) + 1.0E-3*US%m_to_Z > D_pt(i))) nk_valid(I)=0 - endif ; enddo - - - do I=Isq,Ieq ; if (nk_valid(I) > 0) then - ! Calculate the z* interface heights for tracers. - htot = 0.0 ; do k=1,nk_valid(i) ; htot = htot + h_f(k,i) ; enddo - dilate = 0.0 - if (htot > 2.0*Angstrom) then - dilate = MAX((D_pt(i) - shelf_depth(i)), GV%Angstrom_Z)/htot - endif - e(nk_valid(i)+1) = -D_pt(i) - do k=nk_valid(i),1,-1 ; e(K) = e(K+1) + h_f(k,i)*dilate ; enddo - - ! Interpolate each variable into depth space. - k_bot = 1 ; k_bot_prev = -1 - do kz=1,CS%nk_zspace - call find_overlap(e, CS%Z_int(kz), CS%Z_int(kz+1), nk_valid(I), & - k_bot, k_top, k_bot, wt, z1, z2) - if (k_top>nk_valid(I)) exit - - !GM if top range that is being map is below the shelf, interpolate - ! otherwise keep missing_vel - if (CS%Z_int(kz)<=-shelf_depth(I)) then - - if (linear_velocity_profiles) then - k = k_top - if (k /= k_bot_prev) then - ! Calculate the intra-cell profile. - slope = 0.0 ! ; curv = 0.0 - if ((k < nk_valid(I)) .and. (k > nkml)) call & - find_limited_slope(u_f(:,I), e, slope, k) - endif - ! This is the piecewise linear form. - CS%u_z(I,j,kz) = wt(k) * (u_f(k,I) + 0.5*slope*(z2(k) + z1(k))) - ! For the piecewise parabolic form add the following... - ! + C1_3*curv*(z2(k)**2 + z2(k)*z1(k) + z1(k)**2)) - do k=k_top+1,k_bot-1 - CS%u_z(I,j,kz) = CS%u_z(I,j,kz) + wt(k)*u_f(k,I) - enddo - if (k_bot > k_top) then ; k = k_bot - ! Calculate the intra-cell profile. - slope = 0.0 ! ; curv = 0.0 - if ((k < nk_valid(I)) .and. (k > nkml)) call & - find_limited_slope(u_f(:,I), e, slope, k) - ! This is the piecewise linear form. - CS%u_z(I,j,kz) = CS%u_z(I,j,kz) + wt(k) * & - (u_f(k,I) + 0.5*slope*(z2(k) + z1(k))) - ! For the piecewise parabolic form add the following... - ! + C1_3*curv*(z2(k)**2 + z2(k)*z1(k) + z1(k)**2)) - endif - k_bot_prev = k_bot - else ! Use piecewise constant profiles. - CS%u_z(I,j,kz) = wt(k_top)*u_f(k_top,I) - do k=k_top+1,k_bot - CS%u_z(I,j,kz) = CS%u_z(I,j,kz) + wt(k)*u_f(k,I) - enddo - endif ! linear profiles - endif ! below shelf - enddo ! kz-loop - endif ; enddo ! I-loop and mask - enddo ! j-loop - - call post_data(CS%id_u_z, CS%u_z, CS%diag) - endif - - ! meridional velocity component - if (CS%id_v_z > 0) then - do kz=1,CS%nk_zspace ; do J=Jsq,Jeq ; do i=is,ie - CS%v_z(i,J,kz) = CS%missing_vel - enddo ; enddo ; enddo - - do J=Jsq,Jeq - shelf_depth(:) = 0.0 ! initially all is open ocean - ! Remove all massless layers. - do i=is,ie - nk_valid(i) = 0 ; D_pt(i) = 0.5*(G%bathyT(i,j)+G%bathyT(i,j+1)) - if (ice_shelf) then - if (frac_shelf_h(i,j)+frac_shelf_h(i,j+1) > 0.) then ! under shelf - shelf_depth(i) = abs(0.5*(ssh(i,j)+ssh(i,j+1))) - endif - endif - enddo - do k=1,nk ; do i=is,ie - if ((G%mask2dCv(i,j) > 0.5) .and. (h(i,j,k)+h(i,j+1,k) > 4.0*Angstrom)) then - nk_valid(i) = nk_valid(i) + 1 ; k2 = nk_valid(i) - h_f(k2,i) = 0.5*(h(i,j,k)+h(i,j+1,k)) ; v_f(k2,i) = v(i,j,k) - endif - enddo ; enddo - do i=is,ie ; if (G%mask2dCv(i,j) > 0.5) then - ! Add an Angstrom thick layer at the bottom with 0 velocity to impose a - ! no-slip BBC in the output, if anything but piecewise constant is used. - nk_valid(i) = nk_valid(i) + 1 ; k2 = nk_valid(i) - h_f(k2,i) = Angstrom ; v_f(k2,i) = 0.0 - if (ice_shelf .and. shelf_depth(i) + 1.0E-3*US%m_to_Z > D_pt(i)) nk_valid(I)=0 - endif ; enddo - - do i=is,ie ; if (nk_valid(i) > 0) then - ! Calculate the z* interface heights for tracers. - htot = 0.0 ; do k=1,nk_valid(i) ; htot = htot + h_f(k,i) ; enddo - dilate = 0.0 - if (htot > 2.0*Angstrom) then - dilate = MAX((D_pt(i) - shelf_depth(i)), GV%Angstrom_Z)/htot - endif - e(nk_valid(i)+1) = -D_pt(i) - do k=nk_valid(i),1,-1 ; e(K) = e(K+1) + h_f(k,i)*dilate ; enddo - - ! Interpolate each variable into depth space. - k_bot = 1 ; k_bot_prev = -1 - do kz=1,CS%nk_zspace - call find_overlap(e, CS%Z_int(kz), CS%Z_int(kz+1), nk_valid(i), & - k_bot, k_top, k_bot, wt, z1, z2) - if (k_top>nk_valid(i)) exit - !GM if top range that is being map is below the shelf, interpolate - ! otherwise keep missing_vel - if (CS%Z_int(kz)<=-shelf_depth(I)) then - if (linear_velocity_profiles) then - k = k_top - if (k /= k_bot_prev) then - ! Calculate the intra-cell profile. - slope = 0.0 ! ; curv = 0.0 - if ((k < nk_valid(i)) .and. (k > nkml)) call & - find_limited_slope(v_f(:,i), e, slope, k) - endif - ! This is the piecewise linear form. - CS%v_z(i,J,kz) = wt(k) * (v_f(k,i) + 0.5*slope*(z2(k) + z1(k))) - ! For the piecewise parabolic form add the following... - ! + C1_3*curv*(z2(k)**2 + z2(k)*z1(k) + z1(k)**2)) - do k=k_top+1,k_bot-1 - CS%v_z(i,J,kz) = CS%v_z(i,J,kz) + wt(k)*v_f(k,i) - enddo - if (k_bot > k_top) then ; k = k_bot - ! Calculate the intra-cell profile. - slope = 0.0 ! ; curv = 0.0 - if ((k < nk_valid(i)) .and. (k > nkml)) call & - find_limited_slope(v_f(:,i), e, slope, k) - ! This is the piecewise linear form. - CS%v_z(i,J,kz) = CS%v_z(i,J,kz) + wt(k) * & - (v_f(k,i) + 0.5*slope*(z2(k) + z1(k))) - ! For the piecewise parabolic form add the following... - ! + C1_3*curv*(z2(k)**2 + z2(k)*z1(k) + z1(k)**2)) - endif - k_bot_prev = k_bot - else ! Use piecewise constant profiles. - CS%v_z(i,J,kz) = wt(k_top)*v_f(k_top,i) - do k=k_top+1,k_bot - CS%v_z(i,J,kz) = CS%v_z(i,J,kz) + wt(k)*v_f(k,i) - enddo - endif ! linear profiles - endif ! below shelf - enddo ! kz-loop - endif ; enddo ! i-loop and mask - enddo ! J-loop - - call post_data(CS%id_v_z, CS%v_z, CS%diag) - endif - - ! tracer concentrations - if (CS%num_tr_used > 0) then - - do m=1,CS%num_tr_used ; do kz=1,CS%nk_zspace ; do j=js,je ; do i=is,ie - CS%tr_z(m)%p(i,j,kz) = CS%missing_tr(m) - enddo ; enddo ; enddo ; enddo - - do j=js,je - shelf_depth(:) = 0.0 ! initially all is open ocean - ! Remove all massless layers. - do i=is,ie - nk_valid(i) = 0 ; D_pt(i) = G%bathyT(i,j) - if (ice_shelf) then - if (frac_shelf_h(i,j) > 0.) then ! under shelf - shelf_depth(i) = abs(ssh(i,j)) - endif - endif - enddo - do k=1,nk ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (h(i,j,k) > 2.0*Angstrom)) then - nk_valid(i) = nk_valid(i) + 1 ; k2 = nk_valid(i) - h_f(k2,i) = h(i,j,k) - if (ice_shelf .and. shelf_depth(I) + 1.0E-3*US%m_to_Z > D_pt(i)) nk_valid(I)=0 - do m=1,CS%num_tr_used ; tr_f(k2,m,i) = CS%tr_model(m)%p(i,j,k) ; enddo - endif - enddo ; enddo - - do i=is,ie ; if (nk_valid(i) > 0) then - ! Calculate the z* interface heights for tracers. - htot = 0.0 ; do k=1,nk_valid(i) ; htot = htot + h_f(k,i) ; enddo - dilate = 0.0 - if (htot > 2.0*Angstrom) then - dilate = MAX((D_pt(i) - shelf_depth(i)), GV%Angstrom_Z)/htot - endif - e(nk_valid(i)+1) = -D_pt(i) - do k=nk_valid(i),1,-1 ; e(K) = e(K+1) + h_f(k,i)*dilate ; enddo - - ! Interpolate each variable into depth space. - k_bot = 1 ; k_bot_prev = -1 - do kz=1,CS%nk_zspace - call find_overlap(e, CS%Z_int(kz), CS%Z_int(kz+1), nk_valid(i), & - k_bot, k_top, k_bot, wt, z1, z2) - if (k_top>nk_valid(i)) exit - if (CS%Z_int(kz)<=-shelf_depth(i)) then - do m=1,CS%num_tr_used - k = k_top - if (k /= k_bot_prev) then - ! Calculate the intra-cell profile. - sl_tr(m) = 0.0 ! ; cur_tr(m) = 0.0 - if ((k < nk_valid(i)) .and. (k > nkml)) call & - find_limited_slope(tr_f(:,m,i), e, sl_tr(m), k) - endif - ! This is the piecewise linear form. - CS%tr_z(m)%p(i,j,kz) = wt(k) * & - (tr_f(k,m,i) + 0.5*sl_tr(m)*(z2(k) + z1(k))) - ! For the piecewise parabolic form add the following... - ! + C1_3*cur_tr(m)*(z2(k)**2 + z2(k)*z1(k) + z1(k)**2)) - do k=k_top+1,k_bot-1 - CS%tr_z(m)%p(i,j,kz) = CS%tr_z(m)%p(i,j,kz) + wt(k)*tr_f(k,m,i) - enddo - if (k_bot > k_top) then - k = k_bot - ! Calculate the intra-cell profile. - sl_tr(m) = 0.0 ! ; cur_tr(m) = 0.0 - if ((k < nk_valid(i)) .and. (k > nkml)) call & - find_limited_slope(tr_f(:,m,i), e, sl_tr(m), k) - ! This is the piecewise linear form. - CS%tr_z(m)%p(i,j,kz) = CS%tr_z(m)%p(i,j,kz) + wt(k) * & - (tr_f(k,m,i) + 0.5*sl_tr(m)*(z2(k) + z1(k))) - ! For the piecewise parabolic form add the following... - ! + C1_3*cur_tr(m)*(z2(k)**2 + z2(k)*z1(k) + z1(k)**2)) - endif - enddo - k_bot_prev = k_bot - endif ! below shelf - enddo ! kz-loop - endif ; enddo ! i-loop and mask - - enddo ! j-loop - - do m=1,CS%num_tr_used - if (CS%id_tr(m) > 0) call post_data(CS%id_tr(m), CS%tr_z(m)%p, CS%diag) - if (CS%id_tr_xyave(m) > 0) then - layer_ave = global_z_mean(CS%tr_z(m)%p, G, GV, US, CS, m) - call post_data(CS%id_tr_xyave(m), layer_ave, CS%diag) - endif - enddo - endif - -end subroutine calculate_Z_diag_fields - -!> This subroutine maps horizontal transport into depth space for diagnostic output. -subroutine calculate_Z_transport(uh_int, vh_int, h, dt, G, GV, CS) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid - !! structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uh_int !< Time integrated zonal - !! transport [H m2 ~> m3 or kg]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vh_int !< Time integrated meridional - !! transport [H m2 ~> m3 or kg]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, intent(in) :: dt !< The time difference in s since - !! the last call to this - !! subroutine. - type(diag_to_Z_CS), pointer :: CS !< Control structure returned by - !! previous call to - !! diag_to_Z_init. - ! Local variables - real, dimension(SZI_(G), SZJ_(G)) :: & - htot, & ! total layer thickness [H ~> m or kg m-2] - dilate ! Factor by which to dilate layers to convert them - ! into z* space [Z H-1 ~> 1 or m3 kg-1]. (-G%D < z* < 0) - - real, dimension(SZI_(G), max(CS%nk_zspace,1)) :: & - uh_Z ! uh_int interpolated into depth space [H m2 ~> m3 or kg] - real, dimension(SZIB_(G), max(CS%nk_zspace,1)) :: & - vh_Z ! vh_int interpolated into depth space [H m2 ~> m3 or kg] - - real :: h_rem ! dilated thickness of a layer that has yet to be mapped - ! into depth space [Z ~> m] - real :: uh_rem ! integrated zonal transport of a layer that has yet to be - ! mapped into depth space [H m2 ~> m3 or kg] - real :: vh_rem ! integrated meridional transport of a layer that has yet - ! to be mapped into depth space [H m2 ~> m3 or kg] - real :: h_here ! thickness of a layer that is within the range of the - ! current depth level [Z ~> m] - real :: h_above ! thickness of a layer that is above the current depth - ! level [Z ~> m] - real :: uh_here ! zonal transport of a layer that is attributed to the - ! current depth level [H m2 ~> m3 or kg] - real :: vh_here ! meridional transport of a layer that is attributed to - ! the current depth level [H m2 ~> m3 or kg] - real :: Idt ! inverse of the time step [s] - - real :: z_int_above(SZIB_(G)) ! height of the interface atop a layer [H ~> m or kg m-2] - - integer :: kz(SZIB_(G)) ! index of depth level that is being contributed to - - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nk, nk_z - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nk = G%ke - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - - if (.not.associated(CS)) call MOM_error(FATAL, & - "calculate_Z_transport: Module must be initialized before it is used.") - if ((CS%id_uh_Z <= 0) .and. (CS%id_vh_Z <= 0)) return - - Idt = 1.0 ; if (dt > 0.0) Idt = 1.0 / dt - nk_z = CS%nk_zspace - - if (nk_z <= 0) return - - ! Determine how much the layers will be dilated in recasting them into z* - ! coordiantes. (-G%D < z* < 0). - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - htot(i,j) = GV%H_subroundoff - enddo ; enddo - do k=1,nk ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - htot(i,j) = htot(i,j) + h(i,j,k) - enddo ; enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dilate(i,j) = G%bathyT(i,j) / htot(i,j) - enddo ; enddo - - ! zonal transport - if (CS%id_uh_Z > 0) then ; do j=js,je - do I=Isq,Ieq - kz(I) = nk_z ; z_int_above(I) = -0.5*(G%bathyT(i,j)+G%bathyT(i+1,j)) - enddo - do k=nk_z,1,-1 ; do I=Isq,Ieq - uh_Z(I,k) = 0.0 - if (CS%Z_int(k) < z_int_above(I)) kz(I) = k-1 - enddo ; enddo - do k=nk,1,-1 ; do I=Isq,Ieq - h_rem = 0.5*(dilate(i,j)*h(i,j,k) + dilate(i+1,j)*h(i+1,j,k)) - uh_rem = uh_int(I,j,k) - z_int_above(I) = z_int_above(I) + h_rem - - do ! Distribute this layer's transport into the depth-levels. - h_above = z_int_above(I) - CS%Z_int(kz(I)) - if ((kz(I) == 1) .or. (h_above <= 0.0) .or. (h_rem <= 0.0)) then - ! The entire remaining transport is on this level. - uh_Z(I,kz(I)) = uh_Z(I,kz(I)) + uh_rem ; exit - else - h_here = h_rem - h_above - uh_here = uh_rem * (h_here / h_rem) - - h_rem = h_rem - h_here ! = h_above - uh_Z(I,kz(I)) = uh_Z(I,kz(I)) + uh_here - uh_rem = uh_rem - uh_here - kz(I) = kz(I) - 1 - endif - enddo ! End of loop through the target depth-space levels. - enddo ; enddo - do k=1,nk_z ; do I=Isq,Ieq - CS%uh_z(I,j,k) = uh_Z(I,k)*Idt - enddo ; enddo - enddo ; endif - - ! meridional transport - if (CS%id_vh_Z > 0) then ; do J=Jsq,Jeq - do i=is,ie - kz(i) = nk_z ; z_int_above(i) = -0.5*(G%bathyT(i,j)+G%bathyT(i,j+1)) - enddo - do k=nk_z,1,-1 ; do i=is,ie - vh_Z(i,k) = 0.0 - if (CS%Z_int(k) < z_int_above(i)) kz(i) = k-1 - enddo ; enddo - do k=nk,1,-1 ; do i=is,ie - h_rem = 0.5*(dilate(i,j)*h(i,j,k) + dilate(i,j+1)*h(i,j+1,k)) - vh_rem = vh_int(i,J,k) - z_int_above(i) = z_int_above(i) + h_rem - - do ! Distribute this layer's transport into the depth-levels. - h_above = z_int_above(i) - CS%Z_int(kz(i)) - if ((kz(i) == 1) .or. (h_above <= 0.0) .or. (h_rem <= 0.0)) then - ! The entire remaining transport is on this level. - vh_Z(i,kz(i)) = vh_Z(i,kz(i)) + vh_rem ; exit - else - h_here = h_rem - h_above - vh_here = vh_rem * (h_here / h_rem) - - h_rem = h_rem - h_here ! = h_above - vh_Z(i,kz(i)) = vh_Z(i,kz(i)) + vh_here - vh_rem = vh_rem - vh_here - kz(i) = kz(i) - 1 - endif - enddo ! End of loop through the target depth-space levels. - enddo ; enddo - do k=1,nk_z ; do i=is,ie - CS%vh_z(i,J,k) = vh_Z(i,k)*Idt - enddo ; enddo - enddo ; endif - - if (CS%id_uh_Z > 0) then - do k=1,nk_z ; do j=js,je ; do I=Isq,Ieq - CS%uh_z(i,j,k) = CS%uh_z(i,j,k)*GV%H_to_kg_m2 - enddo ; enddo ; enddo - call post_data(CS%id_uh_Z, CS%uh_z, CS%diag) - endif - - if (CS%id_vh_Z > 0) then - do k=1,nk_z ; do j=Jsq,Jeq ; do I=is,ie - CS%vh_z(i,j,k) = CS%vh_z(i,j,k)*GV%H_to_kg_m2 - enddo ; enddo ; enddo - call post_data(CS%id_vh_Z, CS%vh_z, CS%diag) - endif - -end subroutine calculate_Z_transport - -!> Determines the layers bounded by interfaces e that overlap -!! with the depth range between Z_top and Z_bot, and the fractional weights -!! of each layer. It also calculates the normalized relative depths of the range -!! of each layer that overlaps that depth range. -subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z2) - real, dimension(:), intent(in) :: e !< Column interface heights, in arbitrary units. - real, intent(in) :: Z_top !< Top of range being mapped to, in the units of e. - real, intent(in) :: Z_bot !< Bottom of range being mapped to, in the units of e. - integer, intent(in) :: k_max !< Number of valid layers. - integer, intent(in) :: k_start !< Layer at which to start searching. - integer, intent(inout) :: k_top !< Indices of top layers that overlap with the depth - !! range. - integer, intent(inout) :: k_bot !< Indices of bottom layers that overlap with the - !! depth range. - real, dimension(:), intent(out) :: wt !< Relative weights of each layer from k_top to k_bot. - real, dimension(:), intent(out) :: z1 !< Depth of the top limits of the part of - !! a layer that contributes to a depth level, relative to the cell center and normalized - !! by the cell thickness [nondim]. Note that -1/2 <= z1 < z2 <= 1/2. - real, dimension(:), intent(out) :: z2 !< Depths of the bottom limit of the part of - !! a layer that contributes to a depth level, relative to the cell center and normalized - !! by the cell thickness [nondim]. Note that -1/2 <= z1 < z2 <= 1/2. - ! Local variables - real :: Ih, e_c, tot_wt, I_totwt - integer :: k - - do k=k_start,k_max ; if (e(K+1)k_max) return - - ! Determine the fractional weights of each layer. - ! Note that by convention, e and Z_int decrease with increasing k. - if (e(K+1)<=Z_bot) then - wt(k) = 1.0 ; k_bot = k - Ih = 0.0 ; if (e(K) /= e(K+1)) Ih = 1.0 / (e(K)-e(K+1)) - e_c = 0.5*(e(K)+e(K+1)) - z1(k) = (e_c - MIN(e(K),Z_top)) * Ih - z2(k) = (e_c - Z_bot) * Ih - else - wt(k) = MIN(e(K),Z_top) - e(K+1) ; tot_wt = wt(k) ! These are always > 0. - if (e(K) /= e(K+1)) then - z1(k) = (0.5*(e(K)+e(K+1)) - MIN(e(K), Z_top)) / (e(K)-e(K+1)) - else ; z1(k) = -0.5 ; endif - z2(k) = 0.5 - k_bot = k_max - do k=k_top+1,k_max - if (e(K+1)<=Z_bot) then - k_bot = k - wt(k) = e(K) - Z_bot ; z1(k) = -0.5 - if (e(K) /= e(K+1)) then - z2(k) = (0.5*(e(K)+e(K+1)) - Z_bot) / (e(K)-e(K+1)) - else ; z2(k) = 0.5 ; endif - else - wt(k) = e(K) - e(K+1) ; z1(k) = -0.5 ; z2(k) = 0.5 - endif - tot_wt = tot_wt + wt(k) ! wt(k) is always > 0. - if (k>=k_bot) exit - enddo - - I_totwt = 1.0 / tot_wt - do k=k_top,k_bot ; wt(k) = I_totwt*wt(k) ; enddo - endif - -end subroutine find_overlap - -!> This subroutine determines a limited slope for val to be advected with -!! a piecewise limited scheme. -subroutine find_limited_slope(val, e, slope, k) - real, dimension(:), intent(in) :: val !< A column of values that are being interpolated. - real, dimension(:), intent(in) :: e !< Column interface heights in arbitrary units - real, intent(out) :: slope !< Normalized slope in the intracell distribution of val. - integer, intent(in) :: k !< Layer whose slope is being determined. - ! Local variables - real :: d1, d2 ! Thicknesses in the units of e. - - d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) - if (((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) .or. (d1*d2 <= 0.0)) then - slope = 0.0 ! ; curvature = 0.0 - else - slope = (d1**2*(val(k+1) - val(k)) + d2**2*(val(k) - val(k-1))) * & - ((e(K) - e(K+1)) / (d1*d2*(d1+d2))) - ! slope = 0.5*(val(k+1) - val(k-1)) - ! This is S.J. Lin's form of the PLM limiter. - slope = sign(1.0,slope) * min(abs(slope), & - 2.0*(max(val(k-1),val(k),val(k+1)) - val(k)), & - 2.0*(val(k) - min(val(k-1),val(k),val(k+1)))) - ! curvature = 0.0 - endif - -end subroutine find_limited_slope - -!> This subroutine calculates interface diagnostics in z-space. -subroutine calc_Zint_diags(h, in_ptrs, ids, num_diags, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - type(p3d), dimension(:), intent(in) :: in_ptrs !< Pointers to the diagnostics to be regridded - integer, dimension(:), intent(in) :: ids !< The diagnostic IDs of the diagnostics - integer, intent(in) :: num_diags !< The number of diagnostics to regrid - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(diag_to_Z_CS), pointer :: CS !< Control structure returned by - !! previous call to diag_to_Z_init. - ! Local variables - real, dimension(SZI_(G),SZJ_(G),max(CS%nk_zspace+1,1),max(num_diags,1)) :: & - diag_on_Z ! diagnostics interpolated to depth space - real, dimension(SZI_(G),SZK_(G)+1) :: e - real, dimension(max(num_diags,1),SZI_(G),SZK_(G)+1) :: diag2d - - real, dimension(SZI_(G)) :: & - htot, & ! summed layer thicknesses [H ~> m or kg m-2] - dilate ! proportion by which to dilate every layer - real :: wt ! weighting of the interface above in the - ! interpolation to target depths - integer :: kL(SZI_(G)) ! layer-space index of shallowest interface - ! below the target depth - - integer :: i, j, k, k2, kz, is, ie, js, je, nk, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nk = G%ke - - if (num_diags < 1) return - if (.not.associated(CS)) call MOM_error(FATAL, & - "calc_Zint_diags: Module must be initialized before it is used.") - - do j=js,je - ! Calculate the stretched z* interface depths. - do i=is,ie ; htot(i) = 0.0 ; kL(i) = 1 ; enddo - do k=1,nk ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo - do i=is,ie - dilate(i) = 0.0 - if (htot(i) > 0.5*GV%m_to_H) dilate(i) = (G%bathyT(i,j) - 0.0) / htot(i) - e(i,nk+1) = -G%bathyT(i,j) - enddo - do k=nk,1,-1 ; do i=is,ie - e(i,k) = e(i,k+1) + h(i,j,k) * dilate(i) - enddo ; enddo - ! e(i,1) should be 0 as a consistency check. - - do k=1,nk+1 ; do i=is,ie ; do m=1,num_diags - diag2d(m,i,k) = in_ptrs(m)%p(i,j,k) - enddo ; enddo ; enddo - - do kz=1,CS%nk_zspace+1 ; do i=is,ie - ! Find the interface below the target Z-file depth, kL. - if (CS%Z_int(kz) < e(i,nk+1)) then - kL(i) = nk+2 - else - do k=kL(i),nk+1 ; if (CS%Z_int(kz) > e(i,k)) exit ; enddo - kL(i) = k - endif - if (kL(i)>1) then - if (CS%Z_int(kz) > e(i,kL(i)-1)) call MOM_error(FATAL, & - "calc_Zint_diags: Interface depth mapping is incorrect.") - endif - if ((kL(i)>1) .and. (kL(i)<=nk+1)) then - if (e(i,kL(i)-1) == e(i,kL(i))) call MOM_error(WARNING, & - "calc_Zint_diags: Interface depths equal.", all_print=.true.) - if (e(i,kL(i)-1) - e(i,kL(i)) < 0.0) call MOM_error(FATAL, & - "calc_Zint_diags: Interface depths inverted.") - endif - - if (kL(i) <= 1) then - do m=1,num_diags - diag_on_Z(i,j,kz,m) = diag2d(m,i,1) - enddo - elseif (kL(i) > nk+1) then - do m=1,num_diags - diag_on_Z(i,j,kz,m) = CS%missing_value - enddo - else - wt = 0.0 ! This probably should not happen? - if (e(i,kL(i)-1) - e(i,kL(i)) > 0.0) & - wt = (CS%Z_int(kz) - e(i,kL(i))) / (e(i,kL(i)-1) - e(i,kL(i))) - if ((wt < 0.0) .or. (wt > 1.0)) call MOM_error(FATAL, & - "calc_Zint_diags: Bad value of wt found.") - do m=1,num_diags - diag_on_Z(i,j,kz,m) = wt * diag2d(m,i,kL(i)-1) + & - (1.0-wt) * diag2d(m,i,kL(i)) - enddo - endif - enddo ; enddo - - enddo - - do m=1,num_diags - if (ids(m) > 0) call post_data(ids(m), diag_on_Z(:,:,:,m), CS%diag) - enddo - -end subroutine calc_Zint_diags - -!> This subroutine registers a tracer to be output in depth space. -subroutine register_Z_tracer(tr_ptr, name, long_name, units, Time, G, CS, standard_name, & - cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - target, intent(in) :: tr_ptr !< Tracer for translation to Z-space. - character(len=*), intent(in) :: name !< name for the output tracer. - character(len=*), intent(in) :: long_name !< Long name for the output tracer. - character(len=*), intent(in) :: units !< Units of output tracer. - character(len=*), optional, intent(in) :: standard_name !< The CMOR standard name of this variable. - type(time_type), intent(in) :: Time !< Current model time. - type(diag_to_Z_CS), pointer :: CS !< Control struct returned by previous - !! call to diag_to_Z_init. - character(len=*), optional, intent(in) :: cmor_field_name !< cmor name of a field. - character(len=*), optional, intent(in) :: cmor_long_name !< cmor long name of a field. - character(len=*), optional, intent(in) :: cmor_units !< cmor units of a field. - character(len=*), optional, intent(in) :: cmor_standard_name !< cmor standardized name - !! associated with a field. - - ! Local variables - character(len=256) :: posted_standard_name - character(len=256) :: posted_cmor_units - character(len=256) :: posted_cmor_standard_name - character(len=256) :: posted_cmor_long_name - - if (CS%nk_zspace<1) return - - if (present(standard_name)) then - posted_standard_name = standard_name - else - posted_standard_name = 'not provided' - endif - - call register_Z_tracer_low(tr_ptr, name, long_name, units, trim(posted_standard_name), Time, G, CS) - - if (present(cmor_field_name)) then - ! Fallback values for strings set to "NULL" - posted_cmor_units = "not provided" ! - posted_cmor_standard_name = "not provided" ! values might be replaced with a CS%missing field? - posted_cmor_long_name = "not provided" ! - - ! If attributes are present for MOM variable names, use them first for the register_diag_field - ! call for CMOR verison of the variable - posted_cmor_units = units - posted_cmor_long_name = long_name - posted_cmor_standard_name = posted_standard_name - - ! If specified in the call to register_diag_field, override attributes with the CMOR versions - if (present(cmor_units)) posted_cmor_units = cmor_units - if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name - if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name - - call register_Z_tracer_low(tr_ptr, trim(cmor_field_name), trim(posted_cmor_long_name),& - trim(posted_cmor_units), trim(posted_cmor_standard_name), Time, G, CS) - - endif - -end subroutine register_Z_tracer - -!> This subroutine registers a tracer to be output in depth space. -subroutine register_Z_tracer_low(tr_ptr, name, long_name, units, standard_name, Time, G, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - target, intent(in) :: tr_ptr !< Tracer for translation to Z-space. - character(len=*), intent(in) :: name !< Name for the output tracer. - character(len=*), intent(in) :: long_name !< Long name for output tracer. - character(len=*), intent(in) :: units !< Units of output tracer. - character(len=*), intent(in) :: standard_name !< The CMOR standard name of this variable. - type(time_type), intent(in) :: Time !< Current model time. - type(diag_to_Z_CS), pointer :: CS !< Control struct returned by previous call to - !! diag_to_Z_init. - ! Local variables - character(len=256) :: posted_standard_name - integer :: isd, ied, jsd, jed, nk, m, id_test - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nk = G%ke - - if (.not.associated(CS)) call MOM_error(FATAL, & - "register_Z_tracer: Module must be initialized before it is used.") - - if (CS%num_tr_used >= MAX_FIELDS_) then - call MOM_error(WARNING,"MOM_diag_to_Z: Attempted to register and use "//& - "more than MAX_FIELDS_ z-space tracers via register_Z_tracer.") - return - endif - - m = CS%num_tr_used + 1 - - CS%missing_tr(m) = CS%missing_value ! This could be changed later, if desired. - if (CS%nk_zspace > 0) then - CS%id_tr(m) = register_diag_field('ocean_model_zold', name, CS%axesTz, Time, & - long_name, units, missing_value=CS%missing_tr(m), & - standard_name=standard_name) - CS%id_tr_xyave(m) = register_diag_field('ocean_model_zold', trim(name)//'_xyave', CS%axesZ, Time, & - long_name, units, missing_value=CS%missing_tr(m), & - standard_name=standard_name) - else - id_test = register_diag_field('ocean_model_zold', name, CS%diag%axesT1, Time, & - long_name, units, missing_value=CS%missing_tr(m), & - standard_name=standard_name) - if (id_test>0) call MOM_error(WARNING, & - "MOM_diag_to_Z_init: "//trim(name)// & - " cannot be output without an appropriate depth-space target file.") - endif - - if (CS%id_tr(m) <= 0) CS%id_tr(m) = -1 - if (CS%id_tr_xyave(m) <= 0) CS%id_tr_xyave(m) = -1 - if (CS%id_tr(m) > 0 .or. CS%id_tr_xyave(m) > 0) then - CS%num_tr_used = m - call safe_alloc_ptr(CS%tr_z(m)%p,isd,ied,jsd,jed,CS%nk_zspace) - CS%tr_model(m)%p => tr_ptr - endif - -end subroutine register_Z_tracer_low - -!> This subroutine sets parameters that control Z-space diagnostic output. -subroutine MOM_diag_to_Z_init(Time, G, GV, US, param_file, diag, CS) - type(time_type), intent(in) :: Time !< Current model time. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. - type(diag_ctrl), target, intent(inout) :: diag !< Struct to regulate diagnostic output. - type(diag_to_Z_CS), pointer :: CS !< Pointer to point to control structure for - !! this module, which is allocated and - !! populated here. -! This include declares and sets the variable "version". -#include "version_variable.h" - ! Local variables - character(len=40) :: mdl = "MOM_diag_to_Z" ! module name - character(len=200) :: in_dir, zgrid_file ! strings for directory/file - character(len=48) :: flux_units, string - integer :: z_axis, zint_axis - integer :: k, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nk, id_test - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nk = G%ke - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - if (associated(CS)) then - call MOM_error(WARNING, "MOM_diag_to_Z_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - - if (GV%Boussinesq) then ; flux_units = "m3 s-1" - else ; flux_units = "kg s-1" ; endif - - CS%diag => diag - - ! Read parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - ! Read in z-space info from a NetCDF file. - call get_param(param_file, mdl, "Z_OUTPUT_GRID_FILE", zgrid_file, & - "The file that specifies the vertical grid for \n"//& - "depth-space diagnostics, or blank to disable \n"//& - "depth-space output.", default="") - - if (len_trim(zgrid_file) > 0) then - call get_param(param_file, mdl, "INPUTDIR", in_dir, & - "The directory in which input files are found.", default=".") - in_dir = slasher(in_dir) - call get_Z_depths(trim(in_dir)//trim(zgrid_file), "zw", CS%Z_int, "zt", & - z_axis, zint_axis, CS%nk_zspace) - do K=1,CS%nk_zspace+1 ; CS%Z_int(K) = US%m_to_Z*CS%Z_int(K) ; enddo - call log_param(param_file, mdl, "!INPUTDIR/Z_OUTPUT_GRID_FILE", & - trim(in_dir)//trim(zgrid_file)) - call log_param(param_file, mdl, "!NK_ZSPACE (from file)", CS%nk_zspace, & - "The number of depth-space levels. This is determined \n"//& - "from the size of the variable zw in the output grid file.", & - units="nondim") - else - CS%nk_zspace = -1 - endif - - if (CS%nk_zspace > 0) then - - call define_axes_group(diag, (/ diag%axesB1%handles(1), diag%axesB1%handles(2), z_axis /), CS%axesBz) - call define_axes_group(diag, (/ diag%axesT1%handles(1), diag%axesT1%handles(2), z_axis /), CS%axesTz) - call define_axes_group(diag, (/ diag%axesCu1%handles(1), diag%axesCu1%handles(2), z_axis /), CS%axesCuz) - call define_axes_group(diag, (/ diag%axesCv1%handles(1), diag%axesCv1%handles(2), z_axis /), CS%axesCvz) - call define_axes_group(diag, (/ diag%axesB1%handles(1), diag%axesB1%handles(2), zint_axis /), CS%axesBzi) - call define_axes_group(diag, (/ diag%axesT1%handles(1), diag%axesT1%handles(2), zint_axis /), CS%axesTzi) - call define_axes_group(diag, (/ diag%axesCu1%handles(1), diag%axesCu1%handles(2), zint_axis /), CS%axesCuzi) - call define_axes_group(diag, (/ diag%axesCv1%handles(1), diag%axesCv1%handles(2), zint_axis /), CS%axesCvzi) - call define_axes_group(diag, (/ z_axis /), CS%axesZ) - - CS%id_u_z = register_diag_field('ocean_model_zold', 'u', CS%axesCuz, Time, & - 'Zonal Velocity in Depth Space', 'm s-1', & - missing_value=CS%missing_vel, cmor_field_name='uo', cmor_units='m s-1',& - cmor_standard_name='sea_water_x_velocity', cmor_long_name='Sea Water X Velocity') - if (CS%id_u_z>0) call safe_alloc_ptr(CS%u_z,IsdB,IedB,jsd,jed,CS%nk_zspace) - - CS%id_v_z = register_diag_field('ocean_model_zold', 'v', CS%axesCvz, Time, & - 'Meridional Velocity in Depth Space', 'm s-1', & - missing_value=CS%missing_vel, cmor_field_name='vo', cmor_units='m s-1',& - cmor_standard_name='sea_water_y_velocity', cmor_long_name='Sea Water Y Velocity') - if (CS%id_v_z>0) call safe_alloc_ptr(CS%v_z,isd,ied,JsdB,JedB,CS%nk_zspace) - - CS%id_uh_z = register_diag_field('ocean_model_zold', 'uh', CS%axesCuz, Time, & - 'Zonal Mass Transport (including SGS param) in Depth Space', flux_units, & - missing_value=CS%missing_trans) - if (CS%id_uh_z>0) call safe_alloc_ptr(CS%uh_z,IsdB,IedB,jsd,jed,CS%nk_zspace) - - CS%id_vh_z = register_diag_field('ocean_model_zold', 'vh', CS%axesCvz, Time, & - 'Meridional Mass Transport (including SGS param) in Depth Space', flux_units,& - missing_value=CS%missing_trans) - if (CS%id_vh_z>0) call safe_alloc_ptr(CS%vh_z,isd,ied,JsdB,JedB,CS%nk_zspace) - - endif - -end subroutine MOM_diag_to_Z_init - -!> This subroutine reads the depths of the interfaces bounding the intended -!! layers from a NetCDF file. If no appropriate file is found, -1 is returned -!! as the number of layers in the output file. Also, a diag_manager axis is set -!! up with the same information as this axis. -subroutine get_Z_depths(depth_file, int_depth_name, int_depth, cell_depth_name, & - z_axis_index, edge_index, nk_out) - character(len=*), intent(in) :: depth_file !< The file to read for the depths - character(len=*), intent(in) :: int_depth_name !< The interface depth variable name - real, dimension(:), pointer :: int_depth !< A pointer that will be allocated and - !! returned with the interface depths in m - character(len=*), intent(in) :: cell_depth_name !< The cell-center depth variable name - integer, intent(out) :: z_axis_index !< The cell-center z-axis diagnostic index handle - integer, intent(out) :: edge_index !< The interface z-axis diagnostic index handle - integer, intent(out) :: nk_out !< The number of layers in the output grid - ! Local variables - real, allocatable :: cell_depth(:) - character (len=200) :: units, long_name - integer :: ncid, status, intid, intvid, layid, layvid, k, ni - - nk_out = -1 - - status = NF90_OPEN(depth_file, NF90_NOWRITE, ncid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& - " Difficulties opening "//trim(depth_file)//" - "//& - trim(NF90_STRERROR(status))) - nk_out = -1 ; return - endif - - status = NF90_INQ_DIMID(ncid, int_depth_name, intid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& - trim(NF90_STRERROR(status))//" Getting ID of dimension "//& - trim(int_depth_name)//" in "//trim(depth_file)) - nk_out = -1 ; return - endif - - status = nf90_Inquire_Dimension(ncid, intid, len=ni) - if (status /= NF90_NOERR) then - call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& - trim(NF90_STRERROR(status))//" Getting number of interfaces of "//& - trim(int_depth_name)//" in "//trim(depth_file)) - nk_out = -1 ; return - endif - - if (ni < 2) then - call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& - "At least two interface depths must be specified in "//trim(depth_file)) - nk_out = -1 ; return - endif - - status = NF90_INQ_DIMID(ncid, cell_depth_name, layid) - if (status /= NF90_NOERR) call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& - trim(NF90_STRERROR(status))//" Getting ID of dimension "//& - trim(cell_depth_name)//" in "//trim(depth_file)) - - status = nf90_Inquire_Dimension(ncid, layid, len=nk_out) - if (status /= NF90_NOERR) call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& - trim(NF90_STRERROR(status))//" Getting number of interfaces of "//& - trim(cell_depth_name)//" in "//trim(depth_file)) - - if (ni /= nk_out+1) then - call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& - "The interface depths must have one more point than cell centers in "//& - trim(depth_file)) - nk_out = -1 ; return - endif - - allocate(int_depth(nk_out+1)) - allocate(cell_depth(nk_out)) - - status = NF90_INQ_VARID(ncid, int_depth_name, intvid) - if (status /= NF90_NOERR) call MOM_error(FATAL,"MOM_diag_to_Z get_Z_depths: "//& - trim(NF90_STRERROR(status))//" Getting ID of variable "//& - trim(int_depth_name)//" in "//trim(depth_file)) - status = NF90_GET_VAR(ncid, intvid, int_depth) - if (status /= NF90_NOERR) call MOM_error(FATAL,"MOM_diag_to_Z get_Z_depths: "//& - trim(NF90_STRERROR(status))//" Reading variable "//& - trim(int_depth_name)//" in "//trim(depth_file)) - status = NF90_GET_ATT(ncid, intvid, "units", units) - if (status /= NF90_NOERR) units = "m" - status = NF90_GET_ATT(ncid, intvid, "long_name", long_name) - if (status /= NF90_NOERR) long_name = "Depth of edges" - edge_index = diag_axis_init(int_depth_name, int_depth, units, 'z', & - long_name, direction=-1) - -! Create an fms axis with the same data as the cell_depth array in the input file. - status = NF90_INQ_VARID(ncid, cell_depth_name, layvid) - if (status /= NF90_NOERR) call MOM_error(FATAL,"MOM_diag_to_Z get_Z_depths: "//& - trim(NF90_STRERROR(status))//" Getting ID of variable "//& - trim(cell_depth_name)//" in "//trim(depth_file)) - status = NF90_GET_VAR(ncid, layvid, cell_depth) - if (status /= NF90_NOERR) call MOM_error(FATAL,"MOM_diag_to_Z get_Z_depths: "//& - trim(NF90_STRERROR(status))//" Reading variable "//& - trim(cell_depth_name)//" in "//trim(depth_file)) - status = NF90_GET_ATT(ncid, layvid, "units", units) - if (status /= NF90_NOERR) units = "m" - status = NF90_GET_ATT(ncid, layvid, "long_name", long_name) - if (status /= NF90_NOERR) long_name = "Depth of cell center" - - z_axis_index = diag_axis_init(cell_depth_name, cell_depth, units, 'z',& - long_name, edges = edge_index, direction=-1) - - deallocate(cell_depth) - - status = nf90_close(ncid) - - ! Check the sign convention and change to the MOM "height" convention. - if (int_depth(1) < int_depth(2)) then - do k=1,nk_out+1 ; int_depth(k) = -1*int_depth(k) ; enddo - endif - - ! Check for inversions in grid. - do k=1,nk_out ; if (int_depth(k) < int_depth(k+1)) then - call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& - "Inverted interface depths in output grid in "//depth_file) - nk_out = -1 ; deallocate(int_depth) ; return - endif ; enddo - -end subroutine get_Z_depths - -!> Deallocate memory associated with the MOM_diag_to_Z module -subroutine MOM_diag_to_Z_end(CS) - type(diag_to_Z_CS), pointer :: CS !< Control structure returned by a previous call to diag_to_Z_init. - integer :: m - - if (associated(CS%u_z)) deallocate(CS%u_z) - if (associated(CS%v_z)) deallocate(CS%v_z) - if (associated(CS%Z_int)) deallocate(CS%Z_int) - do m=1,CS%num_tr_used ; deallocate(CS%tr_z(m)%p) ; enddo - - deallocate(CS) - -end subroutine MOM_diag_to_Z_end - -!> This subroutine registers a tracer to be output in depth space. -function ocean_register_diag_with_z(tr_ptr, vardesc_tr, G, Time, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - target, intent(in) :: tr_ptr !< Tracer for translation to Z-space. - type(vardesc), intent(in) :: vardesc_tr !< Variable descriptor. - type(time_type), intent(in) :: Time !< Current model time. - type(diag_to_Z_CS), pointer :: CS !< Control struct returned by a previous - !! call to diag_to_Z_init. - integer :: ocean_register_diag_with_z !< The retuned Z-space diagnostic ID - ! Local variables - type(vardesc) :: vardesc_z - character(len=64) :: var_name ! A variable's name. - integer :: isd, ied, jsd, jed, nk, m, id_test - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nk = G%ke - if (.not.associated(CS)) call MOM_error(FATAL, & - "register_Z_tracer: Module must be initialized before it is used.") - if (CS%nk_zspace<1) return - - if (CS%num_tr_used >= MAX_FIELDS_) then - call MOM_error(WARNING,"ocean_register_diag_with_z: Attempted to register and use "//& - "more than MAX_FIELDS_ z-space tracers via ocean_register_diag_with_z.") - return - endif - - ! register the layer tracer - ocean_register_diag_with_z = ocean_register_diag(vardesc_tr, G, CS%diag, Time) - - ! copy layer tracer variable descriptor to a z-tracer descriptor - ! change the name and layer information. - vardesc_z = vardesc_tr - call modify_vardesc(vardesc_z, z_grid="z", caller="ocean_register_diag_with_z") - m = CS%num_tr_used + 1 - CS%missing_tr(m) = CS%missing_value ! This could be changed later, if desired. - CS%id_tr(m) = register_Z_diag(vardesc_z, CS, Time, CS%missing_tr(m)) - - if (CS%nk_zspace > NO_ZSPACE) then -! There is a depth-space target file. - if (CS%id_tr(m)>0) then -! Only allocate the tr_z field id there is a diag_table entry looking -! for it. - CS%num_tr_used = m - call safe_alloc_ptr(CS%tr_z(m)%p,isd,ied,jsd,jed,CS%nk_zspace) -!Can we do the following at this point? -! tr_ptr might not be allocated yet - CS%tr_model(m)%p => tr_ptr - endif - else -! There is no depth-space target file but warn if a diag_table entry is -! present. - call query_vardesc(vardesc_z, name=var_name, caller="ocean_register_diag_with_z") - if (CS%id_tr(m)>0) call MOM_error(WARNING, & - "ocean_register_diag_with_z: "//trim(var_name)// & - " cannot be output without an appropriate depth-space target file.") - endif - -end function ocean_register_diag_with_z - -!> Register a diagnostic to be output in depth space. -function register_Z_diag(var_desc, CS, day, missing) - integer :: register_Z_diag !< The returned z-layer diagnostic index - type(vardesc), intent(in) :: var_desc !< A type with metadata for this diagnostic - type(diag_to_Z_CS), pointer :: CS !< Control structure returned by - !! previous call to diag_to_Z_init. - type(time_type), intent(in) :: day !< The current model time - real, intent(in) :: missing !< The missing value for this diagnostic - ! Local variables - character(len=64) :: var_name ! A variable's name. - character(len=48) :: units ! A variable's units. - character(len=240) :: longname ! A variable's longname. - character(len=8) :: hor_grid, z_grid ! Variable grid info. - type(axes_grp), pointer :: axes => NULL() - - call query_vardesc(var_desc, name=var_name, units=units, longname=longname, & - hor_grid=hor_grid, z_grid=z_grid, caller="register_Zint_diag") - - ! Use the hor_grid and z_grid components of vardesc to determine the - ! desired axes to register the diagnostic field for. - select case (z_grid) - - case ("z") - select case (hor_grid) - case ("q") - axes => CS%axesBz - case ("h") - axes => CS%axesTz - case ("u") - axes => CS%axesCuz - case ("v") - axes => CS%axesCvz - case ("Bu") - axes => CS%axesBz - case ("T") - axes => CS%axesTz - case ("Cu") - axes => CS%axesCuz - case ("Cv") - axes => CS%axesCvz - case default - call MOM_error(FATAL,& - "register_Z_diag: unknown hor_grid component "//trim(hor_grid)) - end select - - case default - call MOM_error(FATAL,& - "register_Z_diag: unknown z_grid component "//trim(z_grid)) - end select - - register_Z_diag = register_diag_field("ocean_model_zold", trim(var_name), axes, & - day, trim(longname), trim(units), missing_value=missing) - -end function register_Z_diag - -!> Register a diagnostic to be output at depth space interfaces -function register_Zint_diag(var_desc, CS, day, conversion) - integer :: register_Zint_diag !< The returned z-interface diagnostic index - type(vardesc), intent(in) :: var_desc !< A type with metadata for this diagnostic - type(diag_to_Z_CS), pointer :: CS !< Control structure returned by - !! previous call to diag_to_Z_init. - type(time_type), intent(in) :: day !< The current model time - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - ! Local variables - character(len=64) :: var_name ! A variable's name. - character(len=48) :: units ! A variable's units. - character(len=240) :: longname ! A variable's longname. - character(len=8) :: hor_grid ! Variable grid info. - type(axes_grp), pointer :: axes => NULL() - - call query_vardesc(var_desc, name=var_name, units=units, longname=longname, & - hor_grid=hor_grid, caller="register_Zint_diag") - - if (CS%nk_zspace < 0) then - register_Zint_diag = -1 ; return - endif - - ! Use the hor_grid and z_grid components of vardesc to determine the - ! desired axes to register the diagnostic field for. - select case (hor_grid) - case ("h") - axes => CS%axesTzi - case ("q") - axes => CS%axesBzi - case ("u") - axes => CS%axesCuzi - case ("v") - axes => CS%axesCvzi - case default - call MOM_error(FATAL,& - "register_Z_diag: unknown hor_grid component "//trim(hor_grid)) - end select - - register_Zint_diag = register_diag_field("ocean_model_zold", trim(var_name), & - axes, day, trim(longname), trim(units), missing_value=CS%missing_value, & - conversion=conversion) - -end function register_Zint_diag - -end module MOM_diag_to_Z diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 767625f1ea..45cfb0ac68 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -13,7 +13,6 @@ module MOM_diagnostics use MOM_diag_mediator, only : diag_get_volume_cell_measure_dm_id use MOM_diag_mediator, only : diag_grid_storage use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids, diag_copy_storage_to_diag -use MOM_diag_to_Z, only : calculate_Z_transport, diag_to_Z_CS use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_North, To_East use MOM_EOS, only : calculate_density, int_density_dz @@ -1077,16 +1076,21 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) end subroutine calculate_energy_diagnostics !> This subroutine registers fields to calculate a diagnostic time derivative. -subroutine register_time_deriv(f_ptr, deriv_ptr, CS) - real, dimension(:,:,:), target :: f_ptr !< Field whose derivative is taken. - real, dimension(:,:,:), target :: deriv_ptr !< Field in which the calculated time derivatives - !! will be placed. +subroutine register_time_deriv(lb, f_ptr, deriv_ptr, CS) + integer, intent(in), dimension(3) :: lb !< Lower index bound of f_ptr + real, dimension(lb(1):,lb(2):,:), target :: f_ptr + !< Time derivative operand + real, dimension(lb(1):,lb(2):,:), target :: deriv_ptr + !< Time derivative of f_ptr type(diagnostics_CS), pointer :: CS !< Control structure returned by previous call to !! diagnostics_init. ! This subroutine registers fields to calculate a diagnostic time derivative. + ! NOTE: Lower bound is required for grid indexing in calculate_derivs(). + ! We assume that the vertical axis is 1-indexed. - integer :: m + integer :: m !< New index of deriv_ptr in CS%deriv + integer :: ub(3) !< Upper index bound of f_ptr, based on shape. if (.not.associated(CS)) call MOM_error(FATAL, & "register_time_deriv: Module must be initialized before it is used.") @@ -1099,9 +1103,11 @@ subroutine register_time_deriv(f_ptr, deriv_ptr, CS) m = CS%num_time_deriv+1 ; CS%num_time_deriv = m - CS%nlay(m) = size(f_ptr(:,:,:),3) + ub(:) = lb(:) + shape(f_ptr) - 1 + + CS%nlay(m) = size(f_ptr, 3) CS%deriv(m)%p => deriv_ptr - allocate(CS%prev_val(m)%p(size(f_ptr(:,:,:),1), size(f_ptr(:,:,:),2), CS%nlay(m)) ) + allocate(CS%prev_val(m)%p(lb(1):ub(1), lb(2):ub(2), CS%nlay(m))) CS%var_ptr(m)%p => f_ptr CS%prev_val(m)%p(:,:,:) = f_ptr(:,:,:) @@ -1122,8 +1128,17 @@ subroutine calculate_derivs(dt, G, CS) if (dt > 0.0) then ; Idt = 1.0/dt else ; return ; endif + ! Because the field is unknown, its grid index bounds are also unknown. + ! Additionally, two of the fields (dudt, dvdt) require calculation of spatial + ! derivatives when computing d(KE)/dt. This raises issues in non-symmetric + ! mode, where the symmetric boundaries (west, south) may not be updated. + + ! For this reason, we explicitly loop from isc-1:iec and jsc-1:jec, in order + ! to force boundary value updates, even though it may not be strictly valid + ! for all fields. Note this assumes a halo, and that it has been updated. + do m=1,CS%num_time_deriv - do k=1,CS%nlay(m) ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + do k=1,CS%nlay(m) ; do j=G%jsc-1,G%jec ; do i=G%isc-1,G%iec CS%deriv(m)%p(i,j,k) = (CS%var_ptr(m)%p(i,j,k) - CS%prev_val(m)%p(i,j,k)) * Idt CS%prev_val(m)%p(i,j,k) = CS%var_ptr(m)%p(i,j,k) enddo ; enddo ; enddo @@ -1313,8 +1328,8 @@ end subroutine post_surface_thermo_diags !> This routine posts diagnostics of the transports, including the subgridscale !! contributions. -subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, diag, dt_trans, & - diag_to_Z_CSp, Reg) +subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, & + diag, dt_trans, Reg) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uhtr !< Accumulated zonal thickness fluxes @@ -1327,8 +1342,6 @@ subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, d type(diag_grid_storage), intent(inout) :: diag_pre_dyn !< Stored grids from before dynamics type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output real, intent(in) :: dt_trans !< total time step associated with the transports [s]. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A control structure for remapping - !! the transports to depth space type(tracer_registry_type), pointer :: Reg !< Pointer to the tracer registry ! Local variables @@ -1347,8 +1360,6 @@ subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, d Idt = 1. / dt_trans H_to_kg_m2_dt = GV%H_to_kg_m2 * Idt - call calculate_Z_transport(uhtr, vhtr, h, dt_trans, G, GV, diag_to_Z_CSp) - call diag_save_grids(diag) call diag_copy_storage_to_diag(diag, diag_pre_dyn) @@ -1428,7 +1439,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag # include "version_variable.h" character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. character(len=48) :: thickness_units, flux_units - logical :: use_temperature + logical :: use_temperature, adiabatic integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nkml, nkbl integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j @@ -1446,15 +1457,17 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%diag => diag use_temperature = associated(tv%T) + call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & + do_not_log=.true.) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version) call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_COLUMN_FRACTION", CS%mono_N2_column_fraction, & - "The lower fraction of water column over which N2 is limited as monotonic\n"// & + "The lower fraction of water column over which N2 is limited as monotonic "// & "for the purposes of calculating the equivalent barotropic wave speed.", & units='nondim', default=0.) call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_DEPTH", CS%mono_N2_depth, & - "The depth below which N2 is limited as monotonic for the\n"// & + "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & units='m', default=-1.) @@ -1556,21 +1569,21 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'Zonal Acceleration', 'm s-2') if ((CS%id_du_dt>0) .and. .not.associated(CS%du_dt)) then call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) - call register_time_deriv(MIS%u, CS%du_dt, CS) + call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) endif CS%id_dv_dt = register_diag_field('ocean_model', 'dvdt', diag%axesCvL, Time, & 'Meridional Acceleration', 'm s-2') if ((CS%id_dv_dt>0) .and. .not.associated(CS%dv_dt)) then call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) - call register_time_deriv(MIS%v, CS%dv_dt, CS) + call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) endif CS%id_dh_dt = register_diag_field('ocean_model', 'dhdt', diag%axesTL, Time, & 'Thickness tendency', trim(thickness_units)//" s-1", v_extensive = .true.) if ((CS%id_dh_dt>0) .and. .not.associated(CS%dh_dt)) then call safe_alloc_ptr(CS%dh_dt,isd,ied,jsd,jed,nz) - call register_time_deriv(MIS%h, CS%dh_dt, CS) + call register_time_deriv(lbound(MIS%h), MIS%h, CS%dh_dt, CS) endif ! layer thickness variables @@ -1631,10 +1644,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'Kinetic Energy Source from Horizontal Viscosity', 'm3 s-3') if (CS%id_KE_horvisc>0) call safe_alloc_ptr(CS%KE_horvisc,isd,ied,jsd,jed,nz) - CS%id_KE_dia = register_diag_field('ocean_model', 'KE_dia', diag%axesTL, Time, & - 'Kinetic Energy Source from Diapycnal Diffusion', 'm3 s-3') - if (CS%id_KE_dia>0) call safe_alloc_ptr(CS%KE_dia,isd,ied,jsd,jed,nz) - + if (.not. adiabatic) then + CS%id_KE_dia = register_diag_field('ocean_model', 'KE_dia', diag%axesTL, Time, & + 'Kinetic Energy Source from Diapycnal Diffusion', 'm3 s-3') + if (CS%id_KE_dia>0) call safe_alloc_ptr(CS%KE_dia,isd,ied,jsd,jed,nz) + endif ! gravity wave CFLs CS%id_cg1 = register_diag_field('ocean_model', 'cg1', diag%axesT1, Time, & @@ -2014,15 +2028,15 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, CS) if (associated(CS%dKE_dt)) then if (.not.associated(CS%du_dt)) then call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) - call register_time_deriv(MIS%u, CS%du_dt, CS) + call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) endif if (.not.associated(CS%dv_dt)) then call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) - call register_time_deriv(MIS%v, CS%dv_dt, CS) + call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) endif if (.not.associated(CS%dh_dt)) then call safe_alloc_ptr(CS%dh_dt,isd,ied,jsd,jed,nz) - call register_time_deriv(MIS%h, CS%dh_dt, CS) + call register_time_deriv(lbound(MIS%h), MIS%h, CS%dh_dt, CS) endif endif diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 4bd5b61255..e30749984d 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -31,8 +31,8 @@ subroutine register_obsolete_diagnostics(param_file, diag) call log_version(param_file, mdl, version) call get_param(param_file, mdl, "OBSOLETE_DIAGNOSTIC_IS_FATAL", causeFatal, & - "If an obsolete diagnostic variable appears in the diag_table\n"// & - "then cause a FATAL error rather than issue a WARNING.", default=.true.) + "If an obsolete diagnostic variable appears in the diag_table, "// & + "cause a FATAL error rather than issue a WARNING.", default=.true.) foundEntry = .false. ! Each obsolete entry, with replacement name is available. diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 23d6f19e4e..0e563648f5 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -204,6 +204,9 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "MSTAR_FIXED", hint="Instead use MSTAR_MODE.") + call obsolete_real(param_file, "MIN_Z_DIAG_INTERVAL") + call obsolete_char(param_file, "Z_OUTPUT_GRID_FILE") + ! Write the file version number to the model log. call log_version(param_file, mdl, version) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index cfc74b47fc..9399f73a58 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -3,6 +3,7 @@ module MOM_sum_output ! This file is part of MOM6. See LICENSE.md for the license. +use iso_fortran_env, only : int64 use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs use MOM_coms, only : reproducing_sum, EFP_to_real, real_to_EFP use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=) @@ -24,6 +25,7 @@ module MOM_sum_output use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type +use mpp_mod, only : mpp_chksum use netcdf @@ -39,6 +41,13 @@ module MOM_sum_output ! vary with the Boussinesq approximation, the Boussinesq variant is given first. integer, parameter :: NUM_FIELDS = 17 !< Number of diagnostic fields +character (*), parameter :: depth_chksum_attr = "bathyT_checksum" + !< Checksum attribute name of G%bathyT + !! over the compute domain +character (*), parameter :: area_chksum_attr = "mask2dT_areaT_checksum" + !< Checksum attribute of name of + !! G%mask2dT * G%areaT over the compute + !! domain !> A list of depths and corresponding globally integrated ocean area at each !! depth and the ocean volume below each depth. @@ -64,6 +73,12 @@ module MOM_sum_output character(len=200) :: depth_list_file !< The name of the depth list file. real :: D_list_min_inc !< The minimum increment [Z ~> m], between the depths of the !! entries in the depth-list file, 0 by default. + logical :: require_depth_list_chksum + !< Require matching checksums in Depth_list.nc when reading + !! the file. + logical :: update_depth_list_chksum + !< Automatically update the Depth_list.nc file if the + !! checksums are missing or do not match current values. logical :: use_temperature !< If true, temperature and salinity are state variables. real :: fresh_water_input !< The total mass of fresh water added by surface fluxes !! since the last time that write_energy was called [kg]. @@ -154,41 +169,41 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "CALCULATE_APE", CS%do_APE_calc, & - "If true, calculate the available potential energy of \n"//& - "the interfaces. Setting this to false reduces the \n"//& + "If true, calculate the available potential energy of "//& + "the interfaces. Setting this to false reduces the "//& "memory footprint of high-PE-count models dramatically.", & default=.true.) call get_param(param_file, mdl, "WRITE_STOCKS", CS%write_stocks, & - "If true, write the integrated tracer amounts to stdout \n"//& + "If true, write the integrated tracer amounts to stdout "//& "when the energy files are written.", default=.true.) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "DT", CS%dt, & "The (baroclinic) dynamics time step.", units="s", & fail_if_missing=.true.) call get_param(param_file, mdl, "MAXTRUNC", CS%maxtrunc, & - "The run will be stopped, and the day set to a very \n"//& - "large value if the velocity is truncated more than \n"//& - "MAXTRUNC times between energy saves. Set MAXTRUNC to 0 \n"//& + "The run will be stopped, and the day set to a very "//& + "large value if the velocity is truncated more than "//& + "MAXTRUNC times between energy saves. Set MAXTRUNC to 0 "//& "to stop if there is any truncation of velocities.", & units="truncations save_interval-1", default=0) call get_param(param_file, mdl, "MAX_ENERGY", CS%max_Energy, & - "The maximum permitted average energy per unit mass; the \n"//& - "model will be stopped if there is more energy than \n"//& + "The maximum permitted average energy per unit mass; the "//& + "model will be stopped if there is more energy than "//& "this. If zero or negative, this is set to 10*MAXVEL^2.", & units="m2 s-2", default=0.0) if (CS%max_Energy <= 0.0) then call get_param(param_file, mdl, "MAXVEL", maxvel, & - "The maximum velocity allowed before the velocity \n"//& + "The maximum velocity allowed before the velocity "//& "components are truncated.", units="m s-1", default=3.0e8) CS%max_Energy = 10.0 * maxvel**2 call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy) endif call get_param(param_file, mdl, "ENERGYFILE", energyfile, & - "The file to use to write the energies and globally \n"//& + "The file to use to write the energies and globally "//& "summed diagnostics.", default="ocean.stats") !query fms_io if there is a filename_appendix (for ensemble runs) @@ -215,10 +230,10 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & if (CS%do_APE_calc) then call get_param(param_file, mdl, "READ_DEPTH_LIST", CS%read_depth_list, & - "Read the depth list from a file if it exists or \n"//& + "Read the depth list from a file if it exists or "//& "create that file otherwise.", default=.false.) call get_param(param_file, mdl, "DEPTH_LIST_MIN_INC", CS%D_list_min_inc, & - "The minimum increment between the depths of the \n"//& + "The minimum increment between the depths of the "//& "entries in the depth-list file.", & units="m", default=1.0E-10, scale=US%m_to_Z) if (CS%read_depth_list) then @@ -226,6 +241,17 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & "The name of the depth list file.", default="Depth_list.nc") if (scan(CS%depth_list_file,'/') == 0) & CS%depth_list_file = trim(slasher(directory))//trim(CS%depth_list_file) + + call get_param(param_file, mdl, "REQUIRE_DEPTH_LIST_CHECKSUMS", & + CS%require_depth_list_chksum, & + "Require that matching checksums be in Depth_list.nc "//& + "when reading the file.", default=.true.) + if (.not. CS%require_depth_list_chksum) & + call get_param(param_file, mdl, "UPDATE_DEPTH_LIST_CHECKSUMS", & + CS%update_depth_list_chksum, & + "Automatically update the Depth_list.nc file if the "//& + "checksums are missing or do not match current values.", & + default=.false.) endif allocate(CS%lH(G%ke)) @@ -238,12 +264,12 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & "The time unit for ENERGYSAVEDAYS.", & units="s", default=86400.0) call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & - "The interval in units of TIMEUNIT between saves of the \n"//& + "The interval in units of TIMEUNIT between saves of the "//& "energies of the run and other globally summed diagnostics.",& default=set_time(0,days=1), timeunit=Time_unit) call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & - "The starting interval in units of TIMEUNIT for the first call \n"//& - "to save the energies of the run and other globally summed diagnostics. \n"//& + "The starting interval in units of TIMEUNIT for the first call "//& + "to save the energies of the run and other globally summed diagnostics. "//& "The interval increases by a factor of 2. after each call to write_energy.",& default=set_time(seconds=0), timeunit=Time_unit) @@ -1102,7 +1128,7 @@ subroutine create_depth_list(G, CS) list_pos = (j_global-1)*G%Domain%niglobal + i_global Dlist(list_pos) = G%bathyT(i,j) - Arealist(list_pos) = G%mask2dT(i,j)*G%areaT(i,j) + Arealist(list_pos) = G%mask2dT(i,j) * G%areaT(i,j) enddo ; enddo ! These sums reproduce across PEs because the arrays are only nonzero on one PE. @@ -1203,6 +1229,10 @@ subroutine write_depth_list(G, US, CS, filename, list_size) ! Local variables real, allocatable :: tmp(:) integer :: ncid, dimid(1), Did, Aid, Vid, status, k + character(len=16) :: depth_chksum, area_chksum + + ! All ranks are required to compute the global checksum + call get_depth_list_checksums(G, depth_chksum, area_chksum) if (.not.is_root_pe()) return @@ -1248,6 +1278,15 @@ subroutine write_depth_list(G, US, CS, filename, list_size) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" vol_below "//trim(NF90_STRERROR(status))) + ! Dependency checksums + status = NF90_PUT_ATT(ncid, NF90_GLOBAL, depth_chksum_attr, depth_chksum) + if (status /= NF90_NOERR) call MOM_error(WARNING, & + filename//" "//depth_chksum_attr//" "//trim(NF90_STRERROR(status))) + + status = NF90_PUT_ATT(ncid, NF90_GLOBAL, area_chksum_attr, area_chksum) + if (status /= NF90_NOERR) call MOM_error(WARNING, & + filename//" "//area_chksum_attr//" "//trim(NF90_STRERROR(status))) + status = NF90_ENDDEF(ncid) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//trim(NF90_STRERROR(status))) @@ -1287,6 +1326,9 @@ subroutine read_depth_list(G, US, CS, filename) real, allocatable :: tmp(:) integer :: ncid, status, varid, list_size, k integer :: ndim, len, var_dim_ids(NF90_MAX_VAR_DIMS) + character(len=16) :: depth_file_chksum, depth_grid_chksum + character(len=16) :: area_file_chksum, area_grid_chksum + integer :: depth_attr_status, area_attr_status mdl = "MOM_sum_output read_depth_list:" @@ -1296,6 +1338,60 @@ subroutine read_depth_list(G, US, CS, filename) " - "//trim(NF90_STRERROR(status))) endif + ! Check bathymetric consistency + depth_attr_status = NF90_GET_ATT(ncid, NF90_GLOBAL, depth_chksum_attr, & + depth_file_chksum) + area_attr_status = NF90_GET_ATT(ncid, NF90_GLOBAL, area_chksum_attr, & + area_file_chksum) + + if (any([depth_attr_status, area_attr_status] == NF90_ENOTATT)) then + var_msg = trim(CS%depth_list_file) // " checksums are missing;" + if (CS%require_depth_list_chksum) then + call MOM_error(FATAL, trim(var_msg) // " aborting.") + elseif (CS%update_depth_list_chksum) then + call MOM_error(WARNING, trim(var_msg) // " updating file.") + call create_depth_list(G, CS) + call write_depth_list(G, US, CS, CS%depth_list_file, CS%list_size+1) + return + else + call MOM_error(WARNING, & + trim(var_msg) // " some diagnostics may not be reproducible.") + endif + else + ! Validate netCDF call + if (depth_attr_status /= NF90_NOERR) then + var_msg = mdl // "Failed to read " // trim(filename) // ":" & + // depth_chksum_attr + call MOM_error(FATAL, & + trim(var_msg) // " - " // NF90_STRERROR(depth_attr_status)) + endif + + if (area_attr_status /= NF90_NOERR) then + var_msg = mdl // "Failed to read " // trim(filename) // ":" & + // area_chksum_attr + call MOM_error(FATAL, & + trim(var_msg) // " - " // NF90_STRERROR(area_attr_status)) + endif + + call get_depth_list_checksums(G, depth_grid_chksum, area_grid_chksum) + + if (depth_grid_chksum /= depth_file_chksum & + .or. area_grid_chksum /= area_file_chksum) then + var_msg = trim(CS%depth_list_file) // " checksums do not match;" + if (CS%require_depth_list_chksum) then + call MOM_error(FATAL, trim(var_msg) // " aborting.") + elseif (CS%update_depth_list_chksum) then + call MOM_error(WARNING, trim(var_msg) // " updating file.") + call create_depth_list(G, CS) + call write_depth_list(G, US, CS, CS%depth_list_file, CS%list_size+1) + return + else + call MOM_error(WARNING, & + trim(var_msg) // " some diagnostics may not be reproducible.") + endif + endif + endif + var_name = "depth" var_msg = trim(var_name)//" in "//trim(filename)//" - " status = NF90_INQ_VARID(ncid, var_name, varid) @@ -1363,6 +1459,42 @@ subroutine read_depth_list(G, US, CS, filename) end subroutine read_depth_list + +!> Return the checksums required to verify DEPTH_LIST_FILE contents. +!! +!! This function computes checksums for the bathymetry (G%bathyT) and masked +!! area (mask2dT * areaT) fields of the model grid G, which are used to compute +!! the depth list. A difference in checksum indicates that a different method +!! was used to compute the grid data, and that any results using the depth +!! list, such as APE, will not be reproducible. +!! +!! Checksums are saved as hexadecimal strings, in order to avoid potential +!! datatype issues with netCDF attributes. +subroutine get_depth_list_checksums(G, depth_chksum, area_chksum) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + character(len=16), intent(out) :: depth_chksum !< Depth checksum hexstring + character(len=16), intent(out) :: area_chksum !< Area checksum hexstring + + integer :: i, j + real, allocatable :: field(:,:) + + allocate(field(G%isc:G%iec, G%jsc:G%jec)) + + ! Depth checksum + do j=G%jsc,G%jec ; do i=G%isc,G%iec + field(i,j) = G%bathyT(i,j) + enddo ; enddo + write(depth_chksum, '(Z16)') mpp_chksum(field(:,:)) + + ! Area checksum + do j=G%jsc,G%jec ; do i=G%isc,G%iec + field(i,j) = G%mask2dT(i,j) * G%areaT(i,j) + enddo ; enddo + write(area_chksum, '(Z16)') mpp_chksum(field(:,:)) + + deallocate(field) +end subroutine get_depth_list_checksums + !> \namespace mom_sum_output !! !! By Robert Hallberg, April 1994 - June 2002 diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index b06ffa0a79..d3b056827b 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -719,9 +719,9 @@ subroutine EOS_init(param_file, EOS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "EQN_OF_STATE", tmpstr, & - "EQN_OF_STATE determines which ocean equation of state \n"//& - "should be used. Currently, the valid choices are \n"//& - '"LINEAR", "UNESCO", "WRIGHT", "NEMO" and "TEOS10". \n'//& + "EQN_OF_STATE determines which ocean equation of state "//& + "should be used. Currently, the valid choices are "//& + '"LINEAR", "UNESCO", "WRIGHT", "NEMO" and "TEOS10". '//& "This is only used if USE_EOS is true.", default=EOS_DEFAULT) select case (uppercase(tmpstr)) case (EOS_LINEAR_STRING) @@ -744,26 +744,26 @@ subroutine EOS_init(param_file, EOS) if (EOS%form_of_EOS == EOS_LINEAR) then EOS%Compressible = .false. call get_param(param_file, mdl, "RHO_T0_S0", EOS%Rho_T0_S0, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", \n"//& + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& "this is the density at T=0, S=0.", units="kg m-3", & default=1000.0) call get_param(param_file, mdl, "DRHO_DT", EOS%dRho_dT, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", \n"//& - "this is the partial derivative of density with \n"//& + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& + "this is the partial derivative of density with "//& "temperature.", units="kg m-3 K-1", default=-0.2) call get_param(param_file, mdl, "DRHO_DS", EOS%dRho_dS, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", \n"//& - "this is the partial derivative of density with \n"//& + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& + "this is the partial derivative of density with "//& "salinity.", units="kg m-3 PSU-1", default=0.8) endif call get_param(param_file, mdl, "EOS_QUADRATURE", EOS%EOS_quadrature, & - "If true, always use the generic (quadrature) code \n"//& + "If true, always use the generic (quadrature) code "//& "code for the integrals of density.", default=.false.) call get_param(param_file, mdl, "TFREEZE_FORM", tmpstr, & - "TFREEZE_FORM determines which expression should be \n"//& - "used for the freezing point. Currently, the valid \n"//& + "TFREEZE_FORM determines which expression should be "//& + "used for the freezing point. Currently, the valid "//& 'choices are "LINEAR", "MILLERO_78", "TEOS10"', & default=TFREEZE_DEFAULT) select case (uppercase(tmpstr)) @@ -780,17 +780,17 @@ subroutine EOS_init(param_file, EOS) if (EOS%form_of_TFreeze == TFREEZE_LINEAR) then call get_param(param_file, mdl, "TFREEZE_S0_P0",EOS%TFr_S0_P0, & - "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", \n"//& - "this is the freezing potential temperature at \n"//& + "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& + "this is the freezing potential temperature at "//& "S=0, P=0.", units="deg C", default=0.0) call get_param(param_file, mdl, "DTFREEZE_DS",EOS%dTFr_dS, & - "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", \n"//& - "this is the derivative of the freezing potential \n"//& + "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& + "this is the derivative of the freezing potential "//& "temperature with salinity.", & units="deg C PSU-1", default=-0.054) call get_param(param_file, mdl, "DTFREEZE_DP",EOS%dTFr_dP, & - "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", \n"//& - "this is the derivative of the freezing potential \n"//& + "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& + "this is the derivative of the freezing potential "//& "temperature with pressure.", & units="deg C Pa-1", default=0.0) endif @@ -1142,7 +1142,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & real :: dz(HIO%iscB:HIO%iecB+1) ! Layer thicknesses at tracer points [Z ~> m]. real :: dz_x(5,HIO%iscB:HIO%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m]. real :: dz_y(5,HIO%isc:HIO%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m]. - real :: weight_t, weight_b ! Nondimensional wieghts of the top and bottom. + real :: weight_t, weight_b ! Nondimensional weights of the top and bottom. real :: massWeightToggle ! A nondimensional toggle factor (0 or 1). real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC]. real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [ppt]. diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index df014dc7a5..c6a23667db 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -10,11 +10,13 @@ module MOM_checksums use MOM_file_parser, only : log_version, param_file_type use MOM_hor_index, only : hor_index_type +use iso_fortran_env, only: error_unit + implicit none ; private +public :: chksum0, zchksum public :: hchksum, Bchksum, uchksum, vchksum, qchksum, is_NaN, chksum public :: hchksum_pair, uvchksum, Bchksum_pair -public :: chksum_general public :: MOM_checksums_init !> Checksums a pair of arrays (2d or 3d) staggered at tracer points @@ -72,11 +74,7 @@ module MOM_checksums module procedure is_NaN_0d, is_NaN_1d, is_NaN_2d, is_NaN_3d end interface -!> Return the bitcount of an array -interface chksum_general - module procedure chksum_general_1d, chksum_general_2d, chksum_general_3d -end interface - +integer, parameter :: bc_modulus = 1000000000 !< Modulus of checksum bitcount integer, parameter :: default_shift=0 !< The default array shift logical :: calculateStatistics=.true. !< If true, report min, max and mean. logical :: writeChksums=.true. !< If true, report the bitcount checksum @@ -85,8 +83,120 @@ module MOM_checksums contains +!> Checksum a scalar field (consistent with array checksums) +subroutine chksum0(scalar, mesg, scale, logunit) + real, intent(in) :: scalar !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + real :: scaling !< Explicit rescaling factor + integer :: iounit !< Log IO unit + real :: rs !< Rescaled scalar + integer :: bc !< Scalar bitcount + + if (checkForNaNs .and. is_NaN(scalar)) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit + + if (calculateStatistics) then + rs = scaling * scalar + if (is_root_pe()) & + call chk_sum_msg(" scalar:", rs, rs, rs, mesg, iounit) + endif + + if (.not. writeChksums) return + + bc = mod(bitcount(abs(scaling * scalar)), bc_modulus) + if (is_root_pe()) & + call chk_sum_msg(" scalar:", bc, mesg, iounit) + +end subroutine chksum0 + + +!> Checksum a 1d array (typically a column). +subroutine zchksum(array, mesg, scale, logunit) + real, dimension(:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + + real, allocatable, dimension(:) :: rescaled_array + real :: scaling + integer :: iounit !< Log IO unit + integer :: k + real :: aMean, aMin, aMax + integer :: bc0 + + if (checkForNaNs) then + if (is_NaN(array(:))) & + call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) + endif + + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit + + if (calculateStatistics) then + if (present(scale)) then + allocate(rescaled_array(LBOUND(array,1):UBOUND(array,1))) + rescaled_array(:) = 0.0 + do k=1, size(array, 1) + rescaled_array(k) = scale * array(k) + enddo + + call subStats(rescaled_array, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(array, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg(" column:", aMean, aMin, aMax, mesg, iounit) + endif + + if (.not. writeChksums) return + + bc0 = subchk(array, scaling) + if (is_root_pe()) call chk_sum_msg(" column:", bc0, mesg, iounit) + + contains + + integer function subchk(array, scale) + real, dimension(:), intent(in) :: array !< The array to be checksummed + real, intent(in) :: scale !< A scaling factor for this array. + integer :: k, bc + subchk = 0 + do k=LBOUND(array, 1), UBOUND(array, 1) + bc = bitcount(abs(scale * array(k))) + subchk = subchk + bc + enddo + subchk=mod(subchk, bc_modulus) + end function subchk + + subroutine subStats(array, aMean, aMin, aMax) + real, dimension(:), intent(in) :: array !< The array to be checksummed + real, intent(out) :: aMean, aMin, aMax + + integer :: k, n + + aMin = array(1) + aMax = array(1) + n = 0 + do k=LBOUND(array,1), UBOUND(array,1) + aMin = min(aMin, array(k)) + aMax = max(aMax, array(k)) + n = n + 1 + enddo + aMean = sum(array(:)) / real(n) + end subroutine subStats + +end subroutine zchksum + !> Checksums on a pair of 2d arrays staggered at tracer points. -subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, scale) +subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & + scale, logunit) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayA !< The first array to be checksummed @@ -94,19 +204,23 @@ subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, s integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging if (present(haloshift)) then - call chksum_h_2d(arrayA, 'x '//mesg, HI, haloshift, omit_corners, scale=scale) - call chksum_h_2d(arrayB, 'y '//mesg, HI, haloshift, omit_corners, scale=scale) + call chksum_h_2d(arrayA, 'x '//mesg, HI, haloshift, omit_corners, & + scale=scale, logunit=logunit) + call chksum_h_2d(arrayB, 'y '//mesg, HI, haloshift, omit_corners, & + scale=scale, logunit=logunit) else - call chksum_h_2d(arrayA, 'x '//mesg, HI, scale=scale) - call chksum_h_2d(arrayB, 'y '//mesg, HI, scale=scale) + call chksum_h_2d(arrayA, 'x '//mesg, HI, scale=scale, logunit=logunit) + call chksum_h_2d(arrayB, 'y '//mesg, HI, scale=scale, logunit=logunit) endif end subroutine chksum_pair_h_2d !> Checksums on a pair of 3d arrays staggered at tracer points. -subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, scale) +subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & + scale, logunit) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:, :), intent(in) :: arrayA !< The first array to be checksummed @@ -114,29 +228,35 @@ subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, s integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging if (present(haloshift)) then - call chksum_h_3d(arrayA, 'x '//mesg, HI, haloshift, omit_corners, scale=scale) - call chksum_h_3d(arrayB, 'y '//mesg, HI, haloshift, omit_corners, scale=scale) + call chksum_h_3d(arrayA, 'x '//mesg, HI, haloshift, omit_corners, & + scale=scale, logunit=logunit) + call chksum_h_3d(arrayB, 'y '//mesg, HI, haloshift, omit_corners, & + scale=scale, logunit=logunit) else - call chksum_h_3d(arrayA, 'x '//mesg, HI, scale=scale) - call chksum_h_3d(arrayB, 'y '//mesg, HI, scale=scale) + call chksum_h_3d(arrayA, 'x '//mesg, HI, scale=scale, logunit=logunit) + call chksum_h_3d(arrayB, 'y '//mesg, HI, scale=scale, logunit=logunit) endif end subroutine chksum_pair_h_3d !> Checksums a 2d array staggered at tracer points. -subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) +subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale, logunit) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging real, allocatable, dimension(:,:) :: rescaled_array real :: scaling + integer :: iounit !< Log IO unit integer :: i, j + real :: aMean, aMin, aMax integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners @@ -147,20 +267,27 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) ! if (is_NaN(array)) & ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)) ) + rescaled_array(:,:) = 0.0 + do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + rescaled_array(i,j) = scale*array(i,j) + enddo ; enddo + call subStats(HI, rescaled_array, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, aMean, aMin, aMax) + endif - if (calculateStatistics) then ; if (present(scale)) then - allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & - LBOUND(array,2):UBOUND(array,2)) ) - rescaled_array(:,:) = 0.0 - do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - rescaled_array(i,j) = scale*array(i,j) - enddo ; enddo - call subStats(HI, rescaled_array, mesg) - deallocate(rescaled_array) - else - call subStats(HI, array, mesg) - endif ; endif + if (is_root_pe()) & + call chk_sum_msg("h-point:", aMean, aMin, aMax, mesg, iounit) + endif if (.not.writeChksums) return @@ -179,7 +306,7 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) bc0 = subchk(array, HI, 0, 0, scaling) if (hshift==0) then - if (is_root_pe()) call chk_sum_msg("h-point:",bc0,mesg) + if (is_root_pe()) call chk_sum_msg("h-point:", bc0, mesg, iounit) return endif @@ -191,14 +318,16 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) bcNW = subchk(array, HI, -hshift, hshift, scaling) bcNE = subchk(array, HI, hshift, hshift, scaling) - if (is_root_pe()) call chk_sum_msg("h-point:",bc0,bcSW,bcSE,bcNW,bcNE,mesg) + if (is_root_pe()) & + call chk_sum_msg("h-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else bcS = subchk(array, HI, 0, -hshift, scaling) bcE = subchk(array, HI, hshift, 0, scaling) bcW = subchk(array, HI, -hshift, 0, scaling) bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) call chk_sum_msg_NSEW("h-point:",bc0,bcN,bcS,bcE,bcW,mesg) + if (is_root_pe()) & + call chk_sum_msg_NSEW("h-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif contains @@ -215,16 +344,15 @@ integer function subchk(array, HI, di, dj, scale) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) - subchk=mod(subchk,1000000000) + subchk=mod(subchk, bc_modulus) end function subchk - subroutine subStats(HI, array, mesg) + subroutine subStats(HI, array, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, intent(out) :: aMean, aMin, aMax integer :: i, j, n - real :: aMean, aMin, aMax aMin = array(HI%isc,HI%jsc) aMax = array(HI%isc,HI%jsc) @@ -239,13 +367,13 @@ subroutine subStats(HI, array, mesg) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("h-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_h_2d !> Checksums on a pair of 2d arrays staggered at q-points. -subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & + omit_corners, scale, logunit) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayA !< The first array to be checksummed @@ -255,6 +383,7 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, omit integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical :: sym @@ -262,18 +391,21 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, omit if (present(haloshift)) then call chksum_B_2d(arrayA, 'x '//mesg, HI, haloshift, symmetric=sym, & - omit_corners=omit_corners, scale=scale) + omit_corners=omit_corners, scale=scale, logunit=logunit) call chksum_B_2d(arrayB, 'y '//mesg, HI, haloshift, symmetric=sym, & - omit_corners=omit_corners, scale=scale) + omit_corners=omit_corners, scale=scale, logunit=logunit) else - call chksum_B_2d(arrayA, 'x '//mesg, HI, symmetric=sym, scale=scale) - call chksum_B_2d(arrayB, 'y '//mesg, HI, symmetric=sym, scale=scale) + call chksum_B_2d(arrayA, 'x '//mesg, HI, symmetric=sym, scale=scale, & + logunit=logunit) + call chksum_B_2d(arrayB, 'y '//mesg, HI, symmetric=sym, scale=scale, & + logunit=logunit) endif end subroutine chksum_pair_B_2d !> Checksums on a pair of 3d arrays staggered at q-points. -subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & + omit_corners, scale, logunit) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:, :), intent(in) :: arrayA !< The first array to be checksummed @@ -283,23 +415,27 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, omit !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical :: sym if (present(haloshift)) then call chksum_B_3d(arrayA, 'x '//mesg, HI, haloshift, symmetric, & - omit_corners, scale=scale) + omit_corners, scale=scale, logunit=logunit) call chksum_B_3d(arrayB, 'y '//mesg, HI, haloshift, symmetric, & - omit_corners, scale=scale) + omit_corners, scale=scale, logunit=logunit) else - call chksum_B_3d(arrayA, 'x '//mesg, HI, symmetric=symmetric, scale=scale) - call chksum_B_3d(arrayB, 'y '//mesg, HI, symmetric=symmetric, scale=scale) + call chksum_B_3d(arrayA, 'x '//mesg, HI, symmetric=symmetric, scale=scale, & + logunit=logunit) + call chksum_B_3d(arrayB, 'y '//mesg, HI, symmetric=symmetric, scale=scale, & + logunit=logunit) endif end subroutine chksum_pair_B_3d !> Checksums a 2d array staggered at corner points. -subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale, logunit) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:), & intent(in) :: array !< The array to be checksummed @@ -309,10 +445,13 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal !! full symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging real, allocatable, dimension(:,:) :: rescaled_array real :: scaling + integer :: iounit !< Log IO unit integer :: i, j, Is, Js + real :: aMean, aMin, aMax integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -323,24 +462,30 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! if (is_NaN(array)) & ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) then ; if (present(scale)) then - allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & - LBOUND(array,2):UBOUND(array,2)) ) - rescaled_array(:,:) = 0.0 - Is = HI%isc ; if (sym_stats) Is = HI%isc-1 - Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 - do J=Js,HI%JecB ; do I=Is,HI%IecB - rescaled_array(I,J) = scale*array(I,J) - enddo ; enddo - call subStats(HI, rescaled_array, mesg, sym_stats) - deallocate(rescaled_array) - else - call subStats(HI, array, mesg, sym_stats) - endif ; endif + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)) ) + rescaled_array(:,:) = 0.0 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do J=Js,HI%JecB ; do I=Is,HI%IecB + rescaled_array(I,J) = scale*array(I,J) + enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + if (is_root_pe()) & + call chk_sum_msg("B-point:", aMean, aMin, aMax, mesg, iounit) + endif if (.not.writeChksums) return @@ -361,7 +506,7 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal sym = .false. ; if (present(symmetric)) sym = symmetric if ((hshift==0) .and. .not.sym) then - if (is_root_pe()) call chk_sum_msg("B-point:",bc0,mesg) + if (is_root_pe()) call chk_sum_msg("B-point:", bc0, mesg, iounit) return endif @@ -379,14 +524,16 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal endif bcNE = subchk(array, HI, hshift, hshift, scaling) - if (is_root_pe()) call chk_sum_msg("B-point:",bc0,bcSW,bcSE,bcNW,bcNE,mesg) + if (is_root_pe()) & + call chk_sum_msg("B-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else bcS = subchk(array, HI, 0, -hshift, scaling) bcE = subchk(array, HI, hshift, 0, scaling) bcW = subchk(array, HI, -hshift, 0, scaling) bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) call chk_sum_msg_NSEW("B-point:",bc0,bcN,bcS,bcE,bcW,mesg) + if (is_root_pe()) & + call chk_sum_msg_NSEW("B-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif contains @@ -405,18 +552,17 @@ integer function subchk(array, HI, di, dj, scale) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) - subchk=mod(subchk,1000000000) + subchk=mod(subchk, bc_modulus) end function subchk - subroutine subStats(HI, array, mesg, sym_stats) + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. + real, intent(out) :: aMean, aMin, aMax integer :: i, j, n, IsB, JsB - real :: aMean, aMin, aMax IsB = HI%isc ; if (sym_stats) IsB = HI%isc-1 JsB = HI%jsc ; if (sym_stats) JsB = HI%jsc-1 @@ -433,13 +579,13 @@ subroutine subStats(HI, array, mesg, sym_stats) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("B-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_B_2d !> Checksums a pair of 2d velocity arrays staggered at C-grid locations -subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & + omit_corners, scale, logunit) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: arrayU !< The u-component array to be checksummed @@ -449,19 +595,25 @@ subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, omit_cor !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for these arrays. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging if (present(haloshift)) then - call chksum_u_2d(arrayU, 'u '//mesg, HI, haloshift, symmetric, omit_corners, scale) - call chksum_v_2d(arrayV, 'v '//mesg, HI, haloshift, symmetric, omit_corners, scale) + call chksum_u_2d(arrayU, 'u '//mesg, HI, haloshift, symmetric, & + omit_corners, scale, logunit=logunit) + call chksum_v_2d(arrayV, 'v '//mesg, HI, haloshift, symmetric, & + omit_corners, scale, logunit=logunit) else - call chksum_u_2d(arrayU, 'u '//mesg, HI, symmetric=symmetric) - call chksum_v_2d(arrayV, 'v '//mesg, HI, symmetric=symmetric) + call chksum_u_2d(arrayU, 'u '//mesg, HI, symmetric=symmetric, & + logunit=logunit) + call chksum_v_2d(arrayV, 'v '//mesg, HI, symmetric=symmetric, & + logunit=logunit) endif end subroutine chksum_uv_2d !> Checksums a pair of 3d velocity arrays staggered at C-grid locations -subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & + omit_corners, scale, logunit) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: arrayU !< The u-component array to be checksummed @@ -471,19 +623,25 @@ subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, omit_cor !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for these arrays. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging if (present(haloshift)) then - call chksum_u_3d(arrayU, 'u '//mesg, HI, haloshift, symmetric, omit_corners, scale) - call chksum_v_3d(arrayV, 'v '//mesg, HI, haloshift, symmetric, omit_corners, scale) + call chksum_u_3d(arrayU, 'u '//mesg, HI, haloshift, symmetric, & + omit_corners, scale, logunit=logunit) + call chksum_v_3d(arrayV, 'v '//mesg, HI, haloshift, symmetric, & + omit_corners, scale, logunit=logunit) else - call chksum_u_3d(arrayU, 'u '//mesg, HI, symmetric=symmetric) - call chksum_v_3d(arrayV, 'v '//mesg, HI, symmetric=symmetric) + call chksum_u_3d(arrayU, 'u '//mesg, HI, symmetric=symmetric, & + logunit=logunit) + call chksum_v_3d(arrayV, 'v '//mesg, HI, symmetric=symmetric, & + logunit=logunit) endif end subroutine chksum_uv_3d !> Checksums a 2d array staggered at C-grid u points. -subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale, logunit) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message @@ -492,10 +650,13 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging real, allocatable, dimension(:,:) :: rescaled_array real :: scaling + integer :: iounit !< Log IO unit integer :: i, j, Is + real :: aMean, aMin, aMax integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -506,24 +667,30 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! if (is_NaN(array)) & ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) then ; if (present(scale)) then - allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & - LBOUND(array,2):UBOUND(array,2)) ) - rescaled_array(:,:) = 0.0 - Is = HI%isc ; if (sym_stats) Is = HI%isc-1 - do j=HI%jsc,HI%jec ; do I=Is,HI%IecB - rescaled_array(I,j) = scale*array(I,j) - enddo ; enddo - call subStats(HI, rescaled_array, mesg, sym_stats) - deallocate(rescaled_array) - else - call subStats(HI, array, mesg, sym_stats) - endif ; endif + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)) ) + rescaled_array(:,:) = 0.0 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + do j=HI%jsc,HI%jec ; do I=Is,HI%IecB + rescaled_array(I,j) = scale*array(I,j) + enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg("u-point:", aMean, aMin, aMax, mesg, iounit) + endif if (.not.writeChksums) return @@ -544,7 +711,7 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal sym = .false. ; if (present(symmetric)) sym = symmetric if ((hshift==0) .and. .not.sym) then - if (is_root_pe()) call chk_sum_msg("u-point:",bc0,mesg) + if (is_root_pe()) call chk_sum_msg("u-point:", bc0, mesg, iounit) return endif @@ -552,7 +719,7 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal if (hshift==0) then bcW = subchk(array, HI, -hshift-1, 0, scaling) - if (is_root_pe()) call chk_sum_msg_W("u-point:",bc0,bcW,mesg) + if (is_root_pe()) call chk_sum_msg_W("u-point:", bc0, bcW, mesg, iounit) elseif (do_corners) then if (sym) then bcSW = subchk(array, HI, -hshift-1, -hshift, scaling) @@ -564,7 +731,8 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal bcSE = subchk(array, HI, hshift, -hshift, scaling) bcNE = subchk(array, HI, hshift, hshift, scaling) - if (is_root_pe()) call chk_sum_msg("u-point:",bc0,bcSW,bcSE,bcNW,bcNE,mesg) + if (is_root_pe()) & + call chk_sum_msg("u-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else bcS = subchk(array, HI, 0, -hshift, scaling) bcE = subchk(array, HI, hshift, 0, scaling) @@ -575,7 +743,8 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal endif bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) call chk_sum_msg_NSEW("u-point:",bc0,bcN,bcS,bcE,bcW,mesg) + if (is_root_pe()) & + call chk_sum_msg_NSEW("u-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif contains @@ -594,18 +763,17 @@ integer function subchk(array, HI, di, dj, scale) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) - subchk=mod(subchk,1000000000) + subchk=mod(subchk, bc_modulus) end function subchk - subroutine subStats(HI, array, mesg, sym_stats) + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. + real, intent(out) :: aMean, aMin, aMax integer :: i, j, n, IsB - real :: aMean, aMin, aMax IsB = HI%isc ; if (sym_stats) IsB = HI%isc-1 @@ -621,13 +789,13 @@ subroutine subStats(HI, array, mesg, sym_stats) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("u-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_u_2d !> Checksums a 2d array staggered at C-grid v points. -subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale, logunit) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message @@ -636,10 +804,13 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging real, allocatable, dimension(:,:) :: rescaled_array real :: scaling + integer :: iounit !< Log IO unit integer :: i, j, Js + real :: aMean, aMin, aMax integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -650,24 +821,30 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! if (is_NaN(array)) & ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) then ; if (present(scale)) then - allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & - LBOUND(array,2):UBOUND(array,2)) ) - rescaled_array(:,:) = 0.0 - Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 - do J=Js,HI%JecB ; do i=HI%isc,HI%iec - rescaled_array(i,J) = scale*array(i,J) - enddo ; enddo - call subStats(HI, rescaled_array, mesg, sym_stats) - deallocate(rescaled_array) - else - call subStats(HI, array, mesg, sym_stats) - endif ; endif + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)) ) + rescaled_array(:,:) = 0.0 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do J=Js,HI%JecB ; do i=HI%isc,HI%iec + rescaled_array(i,J) = scale*array(i,J) + enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg("v-point:", aMean, aMin, aMax, mesg, iounit) + endif if (.not.writeChksums) return @@ -688,7 +865,7 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal sym = .false. ; if (present(symmetric)) sym = symmetric if ((hshift==0) .and. .not.sym) then - if (is_root_pe()) call chk_sum_msg("v-point:",bc0,mesg) + if (is_root_pe()) call chk_sum_msg("v-point:", bc0, mesg, iounit) return endif @@ -696,7 +873,7 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal if (hshift==0) then bcS = subchk(array, HI, 0, -hshift-1, scaling) - if (is_root_pe()) call chk_sum_msg_S("v-point:",bc0,bcS,mesg) + if (is_root_pe()) call chk_sum_msg_S("v-point:", bc0, bcS, mesg, iounit) elseif (do_corners) then if (sym) then bcSW = subchk(array, HI, -hshift, -hshift-1, scaling) @@ -708,7 +885,8 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal bcNW = subchk(array, HI, -hshift, hshift, scaling) bcNE = subchk(array, HI, hshift, hshift, scaling) - if (is_root_pe()) call chk_sum_msg("v-point:",bc0,bcSW,bcSE,bcNW,bcNE,mesg) + if (is_root_pe()) & + call chk_sum_msg("v-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else if (sym) then bcS = subchk(array, HI, 0, -hshift-1, scaling) @@ -719,7 +897,8 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal bcW = subchk(array, HI, -hshift, 0, scaling) bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) call chk_sum_msg_NSEW("v-point:",bc0,bcN,bcS,bcE,bcW,mesg) + if (is_root_pe()) & + call chk_sum_msg_NSEW("v-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif contains @@ -738,18 +917,17 @@ integer function subchk(array, HI, di, dj, scale) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) - subchk=mod(subchk,1000000000) + subchk=mod(subchk, bc_modulus) end function subchk - subroutine subStats(HI, array, mesg, sym_stats) + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. + real, intent(out) :: aMean, aMin, aMax integer :: i, j, n, JsB - real :: aMean, aMin, aMax JsB = HI%jsc ; if (sym_stats) JsB = HI%jsc-1 @@ -765,23 +943,25 @@ subroutine subStats(HI, array, mesg, sym_stats) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("v-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_v_2d !> Checksums a 3d array staggered at tracer points. -subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) +subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale, logunit) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging real, allocatable, dimension(:,:,:) :: rescaled_array real :: scaling + integer :: iounit !< Log IO unit integer :: i, j, k + real :: aMean, aMin, aMax integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners @@ -792,22 +972,29 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) ! if (is_NaN(array)) & ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - if (calculateStatistics) then ; if (present(scale)) then - allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & - LBOUND(array,2):UBOUND(array,2), & - LBOUND(array,3):UBOUND(array,3)) ) - rescaled_array(:,:,:) = 0.0 - do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - rescaled_array(i,j,k) = scale*array(i,j,k) - enddo ; enddo ; enddo + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit + + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)) ) + rescaled_array(:,:,:) = 0.0 + do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + rescaled_array(i,j,k) = scale*array(i,j,k) + enddo ; enddo ; enddo + + call subStats(HI, rescaled_array, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, aMean, aMin, aMax) + endif - call subStats(HI, rescaled_array, mesg) - deallocate(rescaled_array) - else - call subStats(HI, array, mesg) - endif ; endif + if (is_root_pe()) & + call chk_sum_msg("h-point:", aMean, aMin, aMax, mesg, iounit) + endif if (.not.writeChksums) return @@ -826,7 +1013,7 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) bc0 = subchk(array, HI, 0, 0, scaling) if (hshift==0) then - if (is_root_pe()) call chk_sum_msg("h-point:",bc0,mesg) + if (is_root_pe()) call chk_sum_msg("h-point:", bc0, mesg, iounit) return endif @@ -838,14 +1025,16 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) bcNW = subchk(array, HI, -hshift, hshift, scaling) bcNE = subchk(array, HI, hshift, hshift, scaling) - if (is_root_pe()) call chk_sum_msg("h-point:",bc0,bcSW,bcSE,bcNW,bcNE,mesg) + if (is_root_pe()) & + call chk_sum_msg("h-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else bcS = subchk(array, HI, 0, -hshift, scaling) bcE = subchk(array, HI, hshift, 0, scaling) bcW = subchk(array, HI, -hshift, 0, scaling) bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) call chk_sum_msg_NSEW("h-point:",bc0,bcN,bcS,bcE,bcW,mesg) + if (is_root_pe()) & + call chk_sum_msg_NSEW("h-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif contains @@ -863,16 +1052,15 @@ integer function subchk(array, HI, di, dj, scale) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) - subchk=mod(subchk,1000000000) + subchk=mod(subchk, bc_modulus) end function subchk - subroutine subStats(HI, array, mesg) + subroutine subStats(HI, array, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, intent(out) :: aMean, aMin, aMax integer :: i, j, k, n - real :: aMean, aMin, aMax aMin = array(HI%isc,HI%jsc,1) aMax = array(HI%isc,HI%jsc,1) @@ -887,13 +1075,13 @@ subroutine subStats(HI, array, mesg) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("h-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_h_3d !> Checksums a 3d array staggered at corner points. -subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale, logunit) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message @@ -902,10 +1090,13 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging real, allocatable, dimension(:,:,:) :: rescaled_array real :: scaling + integer :: iounit !< Log IO unit integer :: i, j, k, Is, Js + real :: aMean, aMin, aMax integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -916,25 +1107,32 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! if (is_NaN(array)) & ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) then ; if (present(scale)) then - allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & - LBOUND(array,2):UBOUND(array,2), & - LBOUND(array,3):UBOUND(array,3)) ) - rescaled_array(:,:,:) = 0.0 - Is = HI%isc ; if (sym_stats) Is = HI%isc-1 - Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 - do k=1,size(array,3) ; do J=Js,HI%JecB ; do I=Is,HI%IecB - rescaled_array(I,J,k) = scale*array(I,J,k) - enddo ; enddo ; enddo - call subStats(HI, rescaled_array, mesg, sym_stats) - deallocate(rescaled_array) - else - call subStats(HI, array, mesg, sym_stats) - endif ; endif + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)) ) + rescaled_array(:,:,:) = 0.0 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do k=1,size(array,3) ; do J=Js,HI%JecB ; do I=Is,HI%IecB + rescaled_array(I,J,k) = scale*array(I,J,k) + enddo ; enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + + if (is_root_pe()) & + call chk_sum_msg("B-point:", aMean, aMin, aMax, mesg, iounit) + endif if (.not.writeChksums) return @@ -955,7 +1153,7 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal sym = .false. ; if (present(symmetric)) sym = symmetric if ((hshift==0) .and. .not.sym) then - if (is_root_pe()) call chk_sum_msg("B-point:",bc0,mesg) + if (is_root_pe()) call chk_sum_msg("B-point:", bc0, mesg, iounit) return endif @@ -973,7 +1171,8 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal endif bcNE = subchk(array, HI, hshift, hshift, scaling) - if (is_root_pe()) call chk_sum_msg("B-point:",bc0,bcSW,bcSE,bcNW,bcNE,mesg) + if (is_root_pe()) & + call chk_sum_msg("B-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else if (sym) then bcS = subchk(array, HI, 0, -hshift-1, scaling) @@ -985,7 +1184,8 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal bcE = subchk(array, HI, hshift, 0, scaling) bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) call chk_sum_msg_NSEW("B-point:",bc0,bcN,bcS,bcE,bcW,mesg) + if (is_root_pe()) & + call chk_sum_msg_NSEW("B-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif contains @@ -1004,18 +1204,17 @@ integer function subchk(array, HI, di, dj, scale) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) - subchk=mod(subchk,1000000000) + subchk=mod(subchk, bc_modulus) end function subchk - subroutine subStats(HI, array, mesg, sym_stats) + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. + real, intent(out) :: aMean, aMin, aMax integer :: i, j, k, n, IsB, JsB - real :: aMean, aMin, aMax IsB = HI%isc ; if (sym_stats) IsB = HI%isc-1 JsB = HI%jsc ; if (sym_stats) JsB = HI%jsc-1 @@ -1031,13 +1230,13 @@ subroutine subStats(HI, array, mesg, sym_stats) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("B-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_B_3d !> Checksums a 3d array staggered at C-grid u points. -subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale, logunit) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isdB:,HI%Jsd:,:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message @@ -1046,10 +1245,13 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging real, allocatable, dimension(:,:,:) :: rescaled_array real :: scaling + integer :: iounit !< Log IO unit integer :: i, j, k, Is + real :: aMean, aMin, aMax integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -1060,24 +1262,30 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! if (is_NaN(array)) & ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) then ; if (present(scale)) then - allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & - LBOUND(array,2):UBOUND(array,2), & - LBOUND(array,3):UBOUND(array,3)) ) - rescaled_array(:,:,:) = 0.0 - Is = HI%isc ; if (sym_stats) Is = HI%isc-1 - do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do I=Is,HI%IecB - rescaled_array(I,j,k) = scale*array(I,j,k) - enddo ; enddo ; enddo - call subStats(HI, rescaled_array, mesg, sym_stats) - deallocate(rescaled_array) - else - call subStats(HI, array, mesg, sym_stats) - endif ; endif + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)) ) + rescaled_array(:,:,:) = 0.0 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do I=Is,HI%IecB + rescaled_array(I,j,k) = scale*array(I,j,k) + enddo ; enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + if (is_root_pe()) & + call chk_sum_msg("u-point:", aMean, aMin, aMax, mesg, iounit) + endif if (.not.writeChksums) return @@ -1098,7 +1306,7 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal sym = .false. ; if (present(symmetric)) sym = symmetric if ((hshift==0) .and. .not.sym) then - if (is_root_pe()) call chk_sum_msg("u-point:",bc0,mesg) + if (is_root_pe()) call chk_sum_msg("u-point:", bc0, mesg, iounit) return endif @@ -1106,7 +1314,7 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal if (hshift==0) then bcW = subchk(array, HI, -hshift-1, 0, scaling) - if (is_root_pe()) call chk_sum_msg_W("u-point:",bc0,bcW,mesg) + if (is_root_pe()) call chk_sum_msg_W("u-point:", bc0, bcW, mesg, iounit) elseif (do_corners) then if (sym) then bcSW = subchk(array, HI, -hshift-1, -hshift, scaling) @@ -1118,7 +1326,8 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal bcSE = subchk(array, HI, hshift, -hshift, scaling) bcNE = subchk(array, HI, hshift, hshift, scaling) - if (is_root_pe()) call chk_sum_msg("u-point:",bc0,bcSW,bcSE,bcNW,bcNE,mesg) + if (is_root_pe()) & + call chk_sum_msg("u-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else bcS = subchk(array, HI, 0, -hshift, scaling) bcE = subchk(array, HI, hshift, 0, scaling) @@ -1129,7 +1338,8 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal endif bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) call chk_sum_msg_NSEW("u-point:",bc0,bcN,bcS,bcE,bcW,mesg) + if (is_root_pe()) & + call chk_sum_msg_NSEW("u-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif contains @@ -1148,18 +1358,17 @@ integer function subchk(array, HI, di, dj, scale) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) - subchk=mod(subchk,1000000000) + subchk=mod(subchk, bc_modulus) end function subchk - subroutine subStats(HI, array, mesg, sym_stats) + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. + real, intent(out) :: aMean, aMin, aMax integer :: i, j, k, n, IsB - real :: aMean, aMin, aMax IsB = HI%isc ; if (sym_stats) IsB = HI%isc-1 @@ -1175,85 +1384,13 @@ subroutine subStats(HI, array, mesg, sym_stats) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("u-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_u_3d -!> Return the bitcount of an arbitrarily sized 3d array -integer function chksum_general_3d( array, scale_factor, istart, iend, jstart, jend, kstart, kend ) & - result(subchk) - real, dimension(:,:,:), intent(in) :: array !< Array to be checksummed - real, optional, intent(in) :: scale_factor !< Factor to scale array by before checksum - integer, optional, intent(in) :: istart !< Starting index in the i-direction - integer, optional, intent(in) :: iend !< Ending index in the i-direction - integer, optional, intent(in) :: jstart !< Starting index in the j-direction - integer, optional, intent(in) :: jend !< Ending index in the j-direction - integer, optional, intent(in) :: kstart !< Starting index in the k-direction - integer, optional, intent(in) :: kend !< Ending index in the k-direction - integer :: i, j, k, bc, is, ie, js, je, ks, ke - real :: scale - - ! By default do not scale - scale = 1. - if (present(scale_factor)) scale = scale_factor - - ! Set the loop indices based on full array - is = LBOUND(array,1) ; ie = UBOUND(array,1) - js = LBOUND(array,2) ; je = UBOUND(array,2) - ks = LBOUND(array,3) ; ke = UBOUND(array,3) - - ! Override indices if subdomain requested - if (present(istart)) is = istart ; if (present(iend)) ie = iend - if (present(jstart)) js = jstart ; if (present(jend)) je = jend - if (present(kstart)) ks = kstart ; if (present(kend)) ke = kend - - subchk = 0 - do k=ks,ke ; do j=js,je ; do i=is,ie - bc = bitcount(abs(scale*array(i,j,k))) - subchk = subchk + bc - enddo ; enddo ; enddo - call sum_across_PEs(subchk) - subchk=mod(subchk,1000000000) -end function chksum_general_3d - -!> Return the bitcount of an arbitrarily sized 2d array by promotion to a 3d array -integer function chksum_general_2d( array_2d, scale_factor, istart, iend, jstart, jend ) - real, dimension(:,:), intent(in) :: array_2d !< Array to be checksummed - real, optional, intent(in) :: scale_factor !< Factor to scale array by before checksum - integer, optional, intent(in) :: istart !< Starting index in the i-direction - integer, optional, intent(in) :: iend !< Ending index in the i-direction - integer, optional, intent(in) :: jstart !< Starting index in the j-direction - integer, optional, intent(in) :: jend !< Ending index in the j-direction - integer :: is, ie, js, je - real, dimension(:,:,:), allocatable :: array_3d !< Promotion from 2d to 3d array - - is = LBOUND(array_2d,1) ; ie = UBOUND(array_2d,1) - js = LBOUND(array_2d,2) ; je = UBOUND(array_2d,2) - allocate(array_3d(is:ie, js:je,1)) - array_3d(:,:,1) = array_2d(:,:) - chksum_general_2d = chksum_general_3d( array_3d, scale_factor, istart, iend, jstart, jend ) - deallocate(array_3d) -end function chksum_general_2d - -!> Return the bitcount of an arbitrarily sized 1d array by promotion to a 3d array -integer function chksum_general_1d( array_1d, scale_factor, istart, iend ) - real, dimension(:), intent(in) :: array_1d !< Array to be checksummed - real, optional, intent(in) :: scale_factor !< Factor to scale array by before checksum - integer, optional, intent(in) :: istart !< Starting index in the i-direction - integer, optional, intent(in) :: iend !< Ending index in the i-direction - integer :: is, ie - real, dimension(:,:,:), allocatable :: array_3d !< Promotion from 2d to 3d array - - is = LBOUND(array_1d,1) ; ie = UBOUND(array_1d,1) - allocate(array_3d(is:ie, 1,1)) - array_3d(:,1,1) = array_1d(:) - chksum_general_1d = chksum_general_3d( array_3d, scale_factor, istart, iend ) - deallocate(array_3d) -end function chksum_general_1d - !> Checksums a 3d array staggered at C-grid v points. -subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) +subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale, logunit) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message @@ -1262,12 +1399,15 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + integer, optional, intent(in) :: logunit !< IO unit for checksum logging real, allocatable, dimension(:,:,:) :: rescaled_array real :: scaling + integer :: iounit !< Log IO unit integer :: i, j, k, Js integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW + real :: aMean, aMin, aMax logical :: do_corners, sym, sym_stats if (checkForNaNs) then @@ -1276,24 +1416,30 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! if (is_NaN(array)) & ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif + scaling = 1.0 ; if (present(scale)) scaling = scale + iounit = error_unit; if(present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) then ; if (present(scale)) then - allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & - LBOUND(array,2):UBOUND(array,2), & - LBOUND(array,3):UBOUND(array,3)) ) - rescaled_array(:,:,:) = 0.0 - Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 - do k=1,size(array,3) ; do J=Js,HI%JecB ; do i=HI%isc,HI%iec - rescaled_array(i,J,k) = scale*array(i,J,k) - enddo ; enddo ; enddo - call subStats(HI, rescaled_array, mesg, sym_stats) - deallocate(rescaled_array) - else - call subStats(HI, array, mesg, sym_stats) - endif ; endif + if (calculateStatistics) then + if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)) ) + rescaled_array(:,:,:) = 0.0 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do k=1,size(array,3) ; do J=Js,HI%JecB ; do i=HI%isc,HI%iec + rescaled_array(i,J,k) = scale*array(i,J,k) + enddo ; enddo ; enddo + call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) + deallocate(rescaled_array) + else + call subStats(HI, array, sym_stats, aMean, aMin, aMax) + endif + if (is_root_pe()) & + call chk_sum_msg("v-point:", aMean, aMin, aMax, mesg, iounit) + endif if (.not.writeChksums) return @@ -1314,7 +1460,7 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal sym = .false. ; if (present(symmetric)) sym = symmetric if ((hshift==0) .and. .not.sym) then - if (is_root_pe()) call chk_sum_msg("v-point:",bc0,mesg) + if (is_root_pe()) call chk_sum_msg("v-point:", bc0, mesg, iounit) return endif @@ -1322,7 +1468,7 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal if (hshift==0) then bcS = subchk(array, HI, 0, -hshift-1, scaling) - if (is_root_pe()) call chk_sum_msg_S("v-point:",bc0,bcS,mesg) + if (is_root_pe()) call chk_sum_msg_S("v-point:", bc0, bcS, mesg, iounit) elseif (do_corners) then if (sym) then bcSW = subchk(array, HI, -hshift, -hshift-1, scaling) @@ -1334,7 +1480,8 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal bcNW = subchk(array, HI, -hshift, hshift, scaling) bcNE = subchk(array, HI, hshift, hshift, scaling) - if (is_root_pe()) call chk_sum_msg("v-point:",bc0,bcSW,bcSE,bcNW,bcNE,mesg) + if (is_root_pe()) & + call chk_sum_msg("v-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else if (sym) then bcS = subchk(array, HI, 0, -hshift-1, scaling) @@ -1345,7 +1492,8 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal bcW = subchk(array, HI, -hshift, 0, scaling) bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) call chk_sum_msg_NSEW("v-point:",bc0,bcN,bcS,bcE,bcW,mesg) + if (is_root_pe()) & + call chk_sum_msg_NSEW("v-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif contains @@ -1364,18 +1512,18 @@ integer function subchk(array, HI, di, dj, scale) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) - subchk=mod(subchk,1000000000) + subchk=mod(subchk, bc_modulus) end function subchk - subroutine subStats(HI, array, mesg, sym_stats) + !subroutine subStats(HI, array, mesg, sym_stats) + subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. + real, intent(out) :: aMean, aMin, aMax !< Mean/min/max of array over domain integer :: i, j, k, n, JsB - real :: aMean, aMin, aMax JsB = HI%jsc ; if (sym_stats) JsB = HI%jsc-1 @@ -1391,7 +1539,6 @@ subroutine subStats(HI, array, mesg, sym_stats) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("v-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_v_3d @@ -1590,15 +1737,18 @@ function is_NaN_3d(x) end function is_NaN_3d !> Write a message including the checksum of the non-shifted array -subroutine chk_sum_msg1(fmsg,bc0,mesg) +subroutine chk_sum_msg1(fmsg, bc0, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller integer, intent(in) :: bc0 !< The bitcount of the non-shifted array - if (is_root_pe()) write(0,'(A,1(A,I10,X),A)') fmsg," c=",bc0,trim(mesg) + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) & + write(iounit, '(A,1(A,I10,X),A)') fmsg, " c=", bc0, trim(mesg) end subroutine chk_sum_msg1 !> Write a message including checksums of non-shifted and diagonally shifted arrays -subroutine chk_sum_msg5(fmsg,bc0,bcSW,bcSE,bcNW,bcNE,mesg) +subroutine chk_sum_msg5(fmsg, bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller integer, intent(in) :: bc0 !< The bitcount of the non-shifted array @@ -1606,12 +1756,14 @@ subroutine chk_sum_msg5(fmsg,bc0,bcSW,bcSE,bcNW,bcNE,mesg) integer, intent(in) :: bcSE !< The bitcount for SE shifted array integer, intent(in) :: bcNW !< The bitcount for NW shifted array integer, intent(in) :: bcNE !< The bitcount for NE shifted array - if (is_root_pe()) write(0,'(A,5(A,I10,1X),A)') & - fmsg," c=",bc0,"sw=",bcSW,"se=",bcSE,"nw=",bcNW,"ne=",bcNE,trim(mesg) + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,5(A,I10,1X),A)') & + fmsg, " c=", bc0, "sw=", bcSW, "se=", bcSE, "nw=", bcNW, "ne=", bcNE, trim(mesg) end subroutine chk_sum_msg5 !> Write a message including checksums of non-shifted and laterally shifted arrays -subroutine chk_sum_msg_NSEW(fmsg,bc0,bcN,bcS,bcE,bcW,mesg) +subroutine chk_sum_msg_NSEW(fmsg, bc0, bcN, bcS, bcE, bcW, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller integer, intent(in) :: bc0 !< The bitcount of the non-shifted array @@ -1619,49 +1771,59 @@ subroutine chk_sum_msg_NSEW(fmsg,bc0,bcN,bcS,bcE,bcW,mesg) integer, intent(in) :: bcS !< The bitcount for S shifted array integer, intent(in) :: bcE !< The bitcount for E shifted array integer, intent(in) :: bcW !< The bitcount for W shifted array - if (is_root_pe()) write(0,'(A,5(A,I10,1X),A)') & - fmsg," c=",bc0,"N=",bcN,"S=",bcS,"E=",bcE,"W=",bcW,trim(mesg) + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,5(A,I10,1X),A)') & + fmsg, " c=", bc0, "N=", bcN, "S=", bcS, "E=", bcE, "W=", bcW, trim(mesg) end subroutine chk_sum_msg_NSEW !> Write a message including checksums of non-shifted and southward shifted arrays -subroutine chk_sum_msg_S(fmsg,bc0,bcS,mesg) +subroutine chk_sum_msg_S(fmsg, bc0, bcS, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller integer, intent(in) :: bc0 !< The bitcount of the non-shifted array integer, intent(in) :: bcS !< The bitcount of the south-shifted array - if (is_root_pe()) write(0,'(A,2(A,I10,1X),A)') & - fmsg," c=",bc0,"S=",bcS,trim(mesg) + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,2(A,I10,1X),A)') & + fmsg, " c=", bc0, "S=", bcS, trim(mesg) end subroutine chk_sum_msg_S !> Write a message including checksums of non-shifted and westward shifted arrays -subroutine chk_sum_msg_W(fmsg,bc0,bcW,mesg) +subroutine chk_sum_msg_W(fmsg, bc0, bcW, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller integer, intent(in) :: bc0 !< The bitcount of the non-shifted array integer, intent(in) :: bcW !< The bitcount of the west-shifted array - if (is_root_pe()) write(0,'(A,2(A,I10,1X),A)') & - fmsg," c=",bc0,"W=",bcW,trim(mesg) + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,2(A,I10,1X),A)') & + fmsg, " c=", bc0, "W=", bcW, trim(mesg) end subroutine chk_sum_msg_W !> Write a message including checksums of non-shifted and southwestward shifted arrays -subroutine chk_sum_msg2(fmsg,bc0,bcSW,mesg) +subroutine chk_sum_msg2(fmsg, bc0, bcSW, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller integer, intent(in) :: bc0 !< The bitcount of the non-shifted array integer, intent(in) :: bcSW !< The bitcount of the southwest-shifted array - if (is_root_pe()) write(0,'(A,2(A,I9,1X),A)') & - fmsg," c=",bc0,"s/w=",bcSW,trim(mesg) + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,2(A,I9,1X),A)') & + fmsg, " c=", bc0, "s/w=", bcSW, trim(mesg) end subroutine chk_sum_msg2 !> Write a message including the global mean, maximum and minimum of an array -subroutine chk_sum_msg3(fmsg,aMean,aMin,aMax,mesg) +subroutine chk_sum_msg3(fmsg, aMean, aMin, aMax, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller real, intent(in) :: aMean !< The mean value of the array real, intent(in) :: aMin !< The minimum value of the array real, intent(in) :: aMax !< The maximum value of the array - if (is_root_pe()) write(0,'(A,3(A,ES25.16,1X),A)') & - fmsg," mean=",aMean,"min=",aMin,"max=",aMax,trim(mesg) + integer, intent(in) :: iounit !< Checksum logger IO unit + + if (is_root_pe()) write(iounit, '(A,3(A,ES25.16,1X),A)') & + fmsg, " mean=", aMean, "min=", aMin, "max=", aMax, trim(mesg) end subroutine chk_sum_msg3 !> MOM_checksums_init initializes the MOM_checksums module. As it happens, the @@ -1686,7 +1848,7 @@ end subroutine chksum_error !> Does a bitcount of a number by first casting to an integer and then using BTEST !! to check bit by bit -integer function bitcount( x ) +integer function bitcount(x) real :: x !< Number to be bitcount ! Local variables diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index 47601db679..b80ac56baa 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -40,7 +40,11 @@ module MOM_coms !< An array of the real precision of each of the integers real, parameter, dimension(ni) :: & I_pr = (/ 1.0/r_prec**2, 1.0/r_prec, 1.0, r_prec, r_prec**2, r_prec**3 /) - !< An array of the inverse of thereal precision of each of the integers + !< An array of the inverse of the real precision of each of the integers +real, parameter :: max_efp_float = pr(1) * (2.**63 - 1.) + !< The largest float with an EFP representation. + !! NOTE: Only the first bin can exceed precision, + !! but is bounded by the largest signed integer. logical :: overflow_error = .false. !< This becomes true if an overflow is encountered. logical :: NaN_error = .false. !< This becomes true if a NaN is encountered. @@ -515,6 +519,12 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) rs = abs(r) if (rs > abs(max_mag_term)) max_mag_term = r + ! Abort if the number has no EFP representation + if (rs > max_efp_float) then + overflow_error = .true. + return + endif + do i=1,ni ival = int(rs*I_pr(i), 8) rs = rs - ival*pr(i) @@ -535,7 +545,7 @@ subroutine carry_overflow(int_sum, prec_error) ! This subroutine handles carrying of the overflow. integer :: i, num_carry - do i=ni,2,-1 ; if (abs(int_sum(i)) > prec) then + do i=ni,2,-1 ; if (abs(int_sum(i)) >= prec) then num_carry = int(int_sum(i) * I_prec) int_sum(i) = int_sum(i) - num_carry*prec int_sum(i-1) = int_sum(i-1) + num_carry @@ -559,7 +569,7 @@ subroutine regularize_ints(int_sum) logical :: positive integer :: i, num_carry - do i=ni,2,-1 ; if (abs(int_sum(i)) > prec) then + do i=ni,2,-1 ; if (abs(int_sum(i)) >= prec) then num_carry = int(int_sum(i) * I_prec) int_sum(i) = int_sum(i) - num_carry*prec int_sum(i-1) = int_sum(i-1) + num_carry diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 954bf48e90..9320f503b5 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -4,7 +4,8 @@ module MOM_diag_mediator ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_checksums, only : chksum_general +use MOM_checksums, only : chksum0, zchksum +use MOM_checksums, only : hchksum, uchksum, vchksum, Bchksum use MOM_coms, only : PE_here use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE @@ -12,6 +13,7 @@ module MOM_diag_mediator use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, query_vardesc, mom_read_data +use MOM_io, only : get_filename_appendix use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type @@ -237,7 +239,7 @@ module MOM_diag_mediator type, public :: diag_ctrl integer :: available_diag_doc_unit = -1 !< The unit number of a diagnostic documentation file. !! This file is open if available_diag_doc_unit is > 0. - integer :: chksum_diag_doc_unit = -1 !< The unit number of a diagnostic documentation file. + integer :: chksum_iounit = -1 !< The unit number of a diagnostic documentation file. !! This file is open if available_diag_doc_unit is > 0. logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics @@ -327,6 +329,9 @@ module MOM_diag_mediator real, dimension(:,:,:), allocatable :: h_old #endif + !> Number of checksum-only diagnostics + integer :: num_chksum_diags + end type diag_ctrl ! CPU clocks @@ -750,7 +755,7 @@ subroutine set_masks_for_axes(G, diag_cs) call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at h-interfaces') call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated') allocate( axes%mask3d(G%isd:G%ied,G%jsd:G%jed,nk+1) ) ; axes%mask3d(:,:,:) = 0. - do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + do J=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 if (h_axes%mask3d(i,j,1) > 0.) axes%mask3d(i,J,1) = 1. do K = 2, nk if (h_axes%mask3d(i,j,k-1) + h_axes%mask3d(i,j,k) > 0.) axes%mask3d(i,J,k) = 1. @@ -787,7 +792,6 @@ subroutine set_masks_for_axes(G, diag_cs) if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + & h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(I,J,k) = 1. enddo ; enddo ; enddo - endif enddo @@ -1211,7 +1215,9 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) 'post_data_0d: Unregistered diagnostic id') diag => diag_cs%diags(diag_field_id) do while (associated(diag)) - if (is_stat) then + if (diag_cs%diag_as_chksum) then + call chksum0(field, diag%debug_str, logunit=diag_cs%chksum_iounit) + else if (is_stat) then used = send_data(diag%fms_diag_id, field) elseif (diag_cs%ave_enabled) then used = send_data(diag%fms_diag_id, field, diag_cs%time_end) @@ -1261,7 +1267,9 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) locfield => field endif - if (is_stat) then + if (diag_cs%diag_as_chksum) then + call zchksum(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) + else if (is_stat) then used = send_data(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, weight=diag_cs%time_int) @@ -1398,9 +1406,20 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) endif if (diag_cs%diag_as_chksum) then - chksum = chksum_general(locfield) - if (is_root_pe()) then - call log_chksum_diag(diag_cs%chksum_diag_doc_unit, diag%debug_str, chksum) + if (diag%axes%is_h_point) then + call hchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else if (diag%axes%is_u_point) then + call uchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else if (diag%axes%is_v_point) then + call vchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else if (diag%axes%is_q_point) then + call Bchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else + call MOM_error(FATAL, "post_data_2d_low: unknown axis type.") endif else if (is_stat) then @@ -1673,9 +1692,20 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) if (diag%fms_diag_id>0) then if (diag_cs%diag_as_chksum) then - chksum = chksum_general(locfield) - if (is_root_pe()) then - call log_chksum_diag(diag_cs%chksum_diag_doc_unit, diag%debug_str, chksum) + if (diag%axes%is_h_point) then + call hchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else if (diag%axes%is_u_point) then + call uchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else if (diag%axes%is_v_point) then + call vchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else if (diag%axes%is_q_point) then + call Bchksum(locfield, diag%debug_str, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + else + call MOM_error(FATAL, "post_data_3d_low: unknown axis type.") endif else if (is_stat) then @@ -1706,6 +1736,11 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) endif endif endif + + if (diag%fms_xyave_diag_id>0) then + call post_xy_average(diag_cs, diag, locfield) + endif + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & deallocate( locfield ) @@ -1718,6 +1753,7 @@ subroutine post_xy_average(diag_cs, diag, field) type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics mediator control structure ! Local variable real, dimension(size(field,3)) :: averaged_field + logical, dimension(size(field,3)) :: averaged_mask logical :: staggered_in_x, staggered_in_y, used integer :: nz, remap_nz, coord @@ -1732,7 +1768,8 @@ subroutine post_xy_average(diag_cs, diag, field) call horizontally_average_diag_field(diag_cs%G, diag_cs%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & - diag_cs%missing_value, field, averaged_field) + diag_cs%missing_value, field, & + averaged_field, averaged_mask) else nz = size(field, 3) coord = diag%axes%vertical_coordinate_number @@ -1749,11 +1786,17 @@ subroutine post_xy_average(diag_cs, diag, field) call horizontally_average_diag_field(diag_cs%G, diag_cs%diag_remap_cs(coord)%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & - diag_cs%missing_value, field, averaged_field) + diag_cs%missing_value, field, & + averaged_field, averaged_mask) endif - used = send_data(diag%fms_xyave_diag_id, averaged_field, diag_cs%time_end, & - weight=diag_cs%time_int) + if (diag_cs%diag_as_chksum) then + call zchksum(averaged_field, trim(diag%debug_str)//'_xyave', & + logunit=diag_CS%chksum_iounit) + else + used = send_data(diag%fms_xyave_diag_id, averaged_field, diag_cs%time_end, & + weight=diag_cs%time_int, mask=averaged_mask) + endif end subroutine post_xy_average !> This subroutine enables the accumulation of time averages over the specified time interval. @@ -1944,6 +1987,9 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time !Register downsampled diagnostics do dl=2,MAX_DSAMP_LEV + ! Do not attempt to checksum the downsampled diagnostics + if (diag_cs%diag_as_chksum) cycle + new_module_name = trim(module_name)//'_d2' if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then @@ -2108,9 +2154,10 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method=interp_method, tile_count=tile_count) - call attach_cell_methods(fms_id, axes, cm_string, & - cell_methods, x_cell_method, y_cell_method, v_cell_method, & - v_extensive=v_extensive) + if (.not. diag_cs%diag_as_chksum) & + call attach_cell_methods(fms_id, axes, cm_string, cell_methods, & + x_cell_method, y_cell_method, v_cell_method, & + v_extensive=v_extensive) if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then msg = '' if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'"' @@ -2126,8 +2173,9 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & interp_method=interp_method, tile_count=tile_count) - call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, & - cell_methods, v_cell_method, v_extensive=v_extensive) + if (.not. diag_cs%diag_as_chksum) & + call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, & + cell_methods, v_cell_method, v_extensive=v_extensive) if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then msg = '' if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'_xyave"' @@ -2147,7 +2195,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, endif ! For the CMOR variation of the above diagnostic - if (present(cmor_field_name)) then + if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then ! Fallback values for strings set to "NULL" posted_cmor_units = "not provided" ! posted_cmor_standard_name = "not provided" ! Values might be able to be replaced with a CS%missing field? @@ -2244,7 +2292,10 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, volume_id = axes%id_volume ! Get the FMS diagnostic id - if (present(interp_method) .or. axes%is_h_point) then + if (axes%diag_cs%diag_as_chksum) then + fms_id = axes%diag_cs%num_chksum_diags + 1 + axes%diag_cs%num_chksum_diags = fms_id + else if (present(interp_method) .or. axes%is_h_point) then ! If interp_method is provided we must use it if (area_id>0) then if (volume_id>0) then @@ -2556,9 +2607,16 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & diag => null() cmor_diag => null() - fms_id = register_diag_field_fms(module_name, field_name, init_time, & - long_name=long_name, units=units, missing_value=MOM_missing_value, & - range=range, standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg) + if (diag_cs%diag_as_chksum) then + fms_id = diag_cs%num_chksum_diags + 1 + diag_cs%num_chksum_diags = fms_id + else + fms_id = register_diag_field_fms(module_name, field_name, init_time, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, standard_name=standard_name, do_not_log=do_not_log, & + err_msg=err_msg) + endif + if (fms_id /= DIAG_FIELD_NOT_FOUND) then dm_id = get_new_diag_id(diag_cs) call alloc_diag_with_id(dm_id, diag_cs, diag) @@ -2662,11 +2720,17 @@ function register_static_field(module_name, field_name, axes, & diag => null() cmor_diag => null() - fms_id = register_static_field_fms(module_name, field_name, axes%handles, & - long_name=long_name, units=units, missing_value=MOM_missing_value, & - range=range, mask_variant=mask_variant, standard_name=standard_name, & - do_not_log=do_not_log, & - interp_method=interp_method, tile_count=tile_count, area=area) + if (diag_cs%diag_as_chksum) then + fms_id = diag_cs%num_chksum_diags + 1 + diag_cs%num_chksum_diags = fms_id + else + fms_id = register_static_field_fms(module_name, field_name, axes%handles, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + do_not_log=do_not_log, & + interp_method=interp_method, tile_count=tile_count, area=area) + endif + if (fms_id /= DIAG_FIELD_NOT_FOUND) then dm_id = get_new_diag_id(diag_cs) call alloc_diag_with_id(dm_id, diag_cs, diag) @@ -2674,20 +2738,28 @@ function register_static_field(module_name, field_name, axes, & diag%fms_diag_id = fms_id diag%debug_str = trim(module_name)//"-"//trim(field_name) if (present(conversion)) diag%conversion_factor = conversion - if (present(x_cell_method)) then - call get_diag_axis_name(axes%handles(1), axis_name) - call diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) - endif - if (present(y_cell_method)) then - call get_diag_axis_name(axes%handles(2), axis_name) - call diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) - endif - if (present(area_cell_method)) then - call diag_field_add_attribute(fms_id, 'cell_methods', 'area:'//trim(area_cell_method)) + + if (diag_cs%diag_as_chksum) then + diag%axes => axes + else + if (present(x_cell_method)) then + call get_diag_axis_name(axes%handles(1), axis_name) + call diag_field_add_attribute(fms_id, 'cell_methods', & + trim(axis_name)//':'//trim(x_cell_method)) + endif + if (present(y_cell_method)) then + call get_diag_axis_name(axes%handles(2), axis_name) + call diag_field_add_attribute(fms_id, 'cell_methods', & + trim(axis_name)//':'//trim(y_cell_method)) + endif + if (present(area_cell_method)) then + call diag_field_add_attribute(fms_id, 'cell_methods', & + 'area:'//trim(area_cell_method)) + endif endif endif - if (present(cmor_field_name)) then + if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then ! Fallback values for strings set to "not provided" posted_cmor_units = "not provided" posted_cmor_standard_name = "not provided" @@ -2898,6 +2970,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_diag_mediator" ! This module's name. + character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs id_clock_diag_mediator = cpu_clock_id('(Ocean diagnostics framework)', grain=CLOCK_MODULE) id_clock_diag_remap = cpu_clock_id('(Ocean diagnostics remapping)', grain=CLOCK_ROUTINE) @@ -2914,21 +2987,21 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, 'NUM_DIAG_COORDS', diag_cs%num_diag_coords, & - 'The number of diagnostic vertical coordinates to use.\n'//& + 'The number of diagnostic vertical coordinates to use. '//& 'For each coordinate, an entry in DIAG_COORDS must be provided.', & default=1) if (diag_cs%num_diag_coords>0) then allocate(diag_coords(diag_cs%num_diag_coords)) if (diag_cs%num_diag_coords==1) then ! The default is to provide just one instance of Z* call get_param(param_file, mdl, 'DIAG_COORDS', diag_coords, & - 'A list of string tuples associating diag_table modules to\n'//& - 'a coordinate definition used for diagnostics. Each string\n'//& + 'A list of string tuples associating diag_table modules to '//& + 'a coordinate definition used for diagnostics. Each string '//& 'is of the form "MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME".', & default='z Z ZSTAR') else ! If using more than 1 diagnostic coordinate, all must be explicitly defined call get_param(param_file, mdl, 'DIAG_COORDS', diag_coords, & - 'A list of string tuples associating diag_table modules to\n'//& - 'a coordinate definition used for diagnostics. Each string\n'//& + 'A list of string tuples associating diag_table modules to '//& + 'a coordinate definition used for diagnostics. Each string '//& 'is of the form "MODULE_SUFFIX,PARAMETER_SUFFIX,COORDINATE_NAME".', & fail_if_missing=.true.) endif @@ -2944,10 +3017,13 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) 'Set the default missing value to use for diagnostics.', & default=1.e20) call get_param(param_file, mdl, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, & - 'Instead of writing diagnostics to the diag manager, write\n' //& - 'a textfile containing the checksum (bitcount) of the array.', & + 'Instead of writing diagnostics to the diag manager, write '//& + 'a text file containing the checksum (bitcount) of the array.', & default=.false.) + if (diag_cs%diag_as_chksum) & + diag_cs%num_chksum_diags = 0 + ! Keep pointers grid, h, T, S needed diagnostic remapping diag_cs%G => G diag_cs%GV => GV @@ -2982,7 +3058,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) write(this_pe,'(i6.6)') PE_here() doc_file_dflt = "available_diags."//this_pe call get_param(param_file, mdl, "AVAILABLE_DIAGS_FILE", doc_file, & - "A file into which to write a list of all available \n"//& + "A file into which to write a list of all available "//& "ocean diagnostics that can be included in a diag_table.", & default=doc_file_dflt, do_not_log=(diag_CS%available_diag_doc_unit/=-1)) if (len_trim(doc_file) > 0) then @@ -3016,15 +3092,25 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) endif endif - if (is_root_pe() .and. (diag_CS%chksum_diag_doc_unit < 0) .and. diag_CS%diag_as_chksum) then - write(this_pe,'(i6.6)') PE_here() - doc_file_dflt = "chksum_diag."//this_pe + if (is_root_pe() .and. (diag_CS%chksum_iounit < 0) .and. diag_CS%diag_as_chksum) then + !write(this_pe,'(i6.6)') PE_here() + !doc_file_dflt = "chksum_diag."//this_pe + doc_file_dflt = "chksum_diag" call get_param(param_file, mdl, "CHKSUM_DIAG_FILE", doc_file, & - "A file into which to write all checksums of the \n"//& + "A file into which to write all checksums of the "//& "diagnostics listed in the diag_table.", & - default=doc_file_dflt, do_not_log=(diag_CS%chksum_diag_doc_unit/=-1)) + default=doc_file_dflt, do_not_log=(diag_CS%chksum_iounit/=-1)) + + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + doc_file = trim(doc_file) //'.'//trim(filename_appendix) + endif +#ifdef STATSLABEL + doc_file = trim(doc_file)//"."//trim(adjustl(STATSLABEL)) +#endif + if (len_trim(doc_file) > 0) then - new_file = .true. ; if (diag_CS%chksum_diag_doc_unit /= -1) new_file = .false. + new_file = .true. ; if (diag_CS%chksum_iounit /= -1) new_file = .false. ! Find an unused unit number. do new_unit=512,42,-1 inquire( new_unit, opened=opened) @@ -3038,16 +3124,16 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) doc_path = trim(slasher(doc_file_dir))//trim(doc_file) endif ; endif - diag_CS%chksum_diag_doc_unit = new_unit + diag_CS%chksum_iounit = new_unit if (new_file) then - open(diag_CS%chksum_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + open(diag_CS%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & action='WRITE', status='REPLACE', iostat=ios) else ! This file is being reopened, and should be appended. - open(diag_CS%chksum_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + open(diag_CS%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & action='WRITE', status='OLD', position='APPEND', iostat=ios) endif - inquire(diag_CS%chksum_diag_doc_unit, opened=opened) + inquire(diag_CS%chksum_iounit, opened=opened) if ((.not.opened) .or. (ios /= 0)) then call MOM_error(FATAL, "Failed to open checksum diags file "//trim(doc_path)//".") endif @@ -3198,8 +3284,8 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) if (diag_CS%available_diag_doc_unit > -1) then close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -3 endif - if (diag_CS%chksum_diag_doc_unit > -1) then - close(diag_CS%chksum_diag_doc_unit) ; diag_CS%chksum_diag_doc_unit = -3 + if (diag_CS%chksum_iounit > -1) then + close(diag_CS%chksum_iounit) ; diag_CS%chksum_iounit = -3 endif deallocate(diag_cs%diags) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 632258d5d2..6640a4b15a 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -14,11 +14,50 @@ !! 5. diag_remap_do_remap() is called from within a diag post() to do the remapping before !! the diagnostic is written out. + +! NOTE: In the following functions, the fields are passed using 1-based +! indexing, which requires special handling within the grid index loops. +! +! * diag_remap_do_remap +! * vertically_reintegrate_diag_field +! * vertically_interpolate_diag_field +! * horizontally_average_diag_field +! +! Symmetric grids add an additional row of western and southern points to u- +! and v-grids. Non-symmetric grids are 1-based and symmetric grids are +! zero-based, allowing the same expressions to be used when accessing the +! fields. But if u- or v-points become 1-indexed, as in these functions, then +! the stencils must be re-assessed. +! +! For interpolation between h and u grids, we use the following relations: +! +! h->u: f_u[ig] = 0.5 * (f_h[ ig ] + f_h[ig+1]) +! f_u[i1] = 0.5 * (f_h[i1-1] + f_h[ i1 ]) +! +! u->h: f_h[ig] = 0.5 * (f_u[ig-1] + f_u[ ig ]) +! f_h[i1] = 0.5 * (f_u[ i1 ] + f_u[i1+1]) +! +! where ig is the grid index and i1 is the 1-based index. That is, a 1-based +! u-point is ahead of its matching h-point in non-symmetric mode, but behind +! its matching h-point in non-symmetric mode. +! +! We can combine these expressions by applying to ig a -1 shift on u-grids and +! a +1 shift on h-grids in symmetric mode. +! +! We do not adjust the h-point indices, since they are assumed to be 1-based. +! This is only correct when global indexing is disabled. If global indexing is +! enabled, then all indices will need to be defined relative to the data +! domain. +! +! Finally, note that the mask input fields are pointers to arrays which are +! zero-indexed, and do not need any corrections over grid index loops. + + module MOM_diag_remap ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : sum_across_PEs +use MOM_coms, only : reproducing_sum use MOM_error_handler, only : MOM_error, FATAL, assert, WARNING use MOM_diag_vkernels, only : interpolate_column, reintegrate_column use MOM_file_parser, only : get_param, log_param, param_file_type @@ -313,7 +352,10 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ real, dimension(size(h,3)) :: h_src real :: h_neglect, h_neglect_edge integer :: nz_src, nz_dest - integer :: i, j, k + integer :: i, j, k !< Grid index + integer :: i1, j1 !< 1-based index + integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices + integer :: shift !< Symmetric offset for 1-based indexing call assert(remap_cs%initialized, 'diag_remap_do_remap: remap_cs not initialized.') call assert(size(field, 3) == size(h, 3), & @@ -330,31 +372,40 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ nz_dest = remap_cs%nz remapped_field(:,:,:) = 0. + ! Symmetric grid offset under 1-based indexing; see header for details. + shift = 0; if (G%symmetric) shift = 1 + if (staggered_in_x .and. .not. staggered_in_y) then ! U-points do j=G%jsc, G%jec do I=G%iscB, G%iecB + I1 = I - G%isdB + 1 + i_lo = I1 - shift; i_hi = i_lo + 1 if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle + if (mask(I,j,1) == 0.) cycle endif - h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) - call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & - nz_dest, h_dest(:), remapped_field(I,j,:), & + h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) + call remapping_core_h(remap_cs%remap_cs, & + nz_src, h_src(:), field(I1,j,:), & + nz_dest, h_dest(:), remapped_field(I1,j,:), & h_neglect, h_neglect_edge) enddo enddo elseif (staggered_in_y .and. .not. staggered_in_x) then ! V-points do J=G%jscB, G%jecB + J1 = J - G%jsdB + 1 + j_lo = J1 - shift; j_hi = j_lo + 1 do i=G%isc, G%iec if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle + if (mask(i,J,1) == 0.) cycle endif - h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:) ) - call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & - nz_dest, h_dest(:), remapped_field(i,J,:), & + h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) + call remapping_core_h(remap_cs%remap_cs, & + nz_src, h_src(:), field(i,J1,:), & + nz_dest, h_dest(:), remapped_field(i,J1,:), & h_neglect, h_neglect_edge) enddo enddo @@ -363,11 +414,12 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ do j=G%jsc, G%jec do i=G%isc, G%iec if (associated(mask)) then - if (mask(i,j, 1) == 0.) cycle + if (mask(i,j,1) == 0.) cycle endif h_src(:) = h(i,j,:) h_dest(:) = remap_cs%h(i,j,:) - call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,j,:), & + call remapping_core_h(remap_cs%remap_cs, & + nz_src, h_src(:), field(i,j,:), & nz_dest, h_dest(:), remapped_field(i,j,:), & h_neglect, h_neglect_edge) enddo @@ -437,7 +489,10 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, sta real, dimension(remap_cs%nz) :: h_dest real, dimension(size(h,3)) :: h_src integer :: nz_src, nz_dest - integer :: i, j, k + integer :: i, j, k !< Grid index + integer :: i1, j1 !< 1-based index + integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices + integer :: shift !< Symmetric offset for 1-based indexing call assert(remap_cs%initialized, 'vertically_reintegrate_diag_field: remap_cs not initialized.') call assert(size(field, 3) == size(h, 3), & @@ -447,30 +502,37 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, sta nz_dest = remap_cs%nz reintegrated_field(:,:,:) = 0. + ! Symmetric grid offset under 1-based indexing; see header for details. + shift = 0; if (G%symmetric) shift = 1 + if (staggered_in_x .and. .not. staggered_in_y) then ! U-points do j=G%jsc, G%jec do I=G%iscB, G%iecB + I1 = I - G%isdB + 1 + i_lo = I1 - shift; i_hi = i_lo + 1 if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle + if (mask(I,j,1) == 0.) cycle endif - h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) - h_dest(:) = 0.5 * ( remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:) ) - call reintegrate_column(nz_src, h_src, field(I,j,:), & - nz_dest, h_dest, 0., reintegrated_field(I,j,:)) + h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) + call reintegrate_column(nz_src, h_src, field(I1,j,:), & + nz_dest, h_dest, 0., reintegrated_field(I1,j,:)) enddo enddo elseif (staggered_in_y .and. .not. staggered_in_x) then ! V-points do J=G%jscB, G%jecB + J1 = J - G%jsdB + 1 + j_lo = J1 - shift; j_hi = j_lo + 1 do i=G%isc, G%iec if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle + if (mask(i,J,1) == 0.) cycle endif - h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) - h_dest(:) = 0.5 * ( remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:) ) - call reintegrate_column(nz_src, h_src, field(i,J,:), & - nz_dest, h_dest, 0., reintegrated_field(i,J,:)) + h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) + call reintegrate_column(nz_src, h_src, field(i,J1,:), & + nz_dest, h_dest, 0., reintegrated_field(i,J1,:)) enddo enddo elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then @@ -478,7 +540,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, sta do j=G%jsc, G%jec do i=G%isc, G%iec if (associated(mask)) then - if (mask(i,j, 1) == 0.) cycle + if (mask(i,j,1) == 0.) cycle endif h_src(:) = h(i,j,:) h_dest(:) = remap_cs%h(i,j,:) @@ -508,7 +570,10 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta real, dimension(remap_cs%nz) :: h_dest real, dimension(size(h,3)) :: h_src integer :: nz_src, nz_dest - integer :: i, j, k + integer :: i, j, k !< Grid index + integer :: i1, j1 !< 1-based index + integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices + integer :: shift !< Symmetric offset for 1-based indexing call assert(remap_cs%initialized, 'vertically_interpolate_diag_field: remap_cs not initialized.') call assert(size(field, 3) == size(h, 3)+1, & @@ -519,30 +584,37 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta nz_src = size(h,3) nz_dest = remap_cs%nz + ! Symmetric grid offset under 1-based indexing; see header for details. + shift = 0; if (G%symmetric) shift = 1 + if (staggered_in_x .and. .not. staggered_in_y) then ! U-points do j=G%jsc, G%jec do I=G%iscB, G%iecB + I1 = I - G%isdB + 1 + i_lo = I1 - shift; i_hi = i_lo + 1 if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle + if (mask(I,j,1) == 0.) cycle endif - h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) - h_dest(:) = 0.5 * ( remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:) ) - call interpolate_column(nz_src, h_src, field(I,j,:), & - nz_dest, h_dest, 0., interpolated_field(I,j,:)) + h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) + call interpolate_column(nz_src, h_src, field(I1,j,:), & + nz_dest, h_dest, 0., interpolated_field(I1,j,:)) enddo enddo elseif (staggered_in_y .and. .not. staggered_in_x) then ! V-points do J=G%jscB, G%jecB + J1 = J - G%jsdB + 1 + j_lo = J1 - shift; j_hi = j_lo + 1 do i=G%isc, G%iec if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle + if (mask(i,J,1) == 0.) cycle endif - h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) - h_dest(:) = 0.5 * ( remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:) ) - call interpolate_column(nz_src, h_src, field(i,J,:), & - nz_dest, h_dest, 0., interpolated_field(i,J,:)) + h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) + call interpolate_column(nz_src, h_src, field(i,J1,:), & + nz_dest, h_dest, 0., interpolated_field(i,J1,:)) enddo enddo elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then @@ -550,7 +622,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta do j=G%jsc, G%jec do i=G%isc, G%iec if (associated(mask)) then - if (mask(i,j, 1) == 0.) cycle + if (mask(i,j,1) == 0.) cycle endif h_src(:) = h(i,j,:) h_dest(:) = remap_cs%h(i,j,:) @@ -567,7 +639,8 @@ end subroutine vertically_interpolate_diag_field !> Horizontally average field subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, & is_layer, is_extensive, & - missing_value, field, averaged_field) + missing_value, field, averaged_field, & + averaged_mask) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure real, dimension(:,:,:), intent(in) :: h !< The current thicknesses logical, intent(in) :: staggered_in_x !< True if the x-axis location is at u or q points @@ -577,13 +650,20 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, real, intent(in) :: missing_value !< A missing_value to assign land/vanished points real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped real, dimension(:), intent(inout) :: averaged_field !< Field argument horizontally averaged + logical, dimension(:), intent(inout) :: averaged_mask !< Mask for horizontally averaged field + ! Local variables + real, dimension(G%isc:G%iec, G%jsc:G%jec, size(field,3)) :: volume, stuff real, dimension(size(field, 3)) :: vol_sum, stuff_sum ! nz+1 is needed for interface averages - real :: v1, v2, total_volume, total_stuff, val + real :: height integer :: i, j, k, nz + integer :: i1, j1 !< 1-based index nz = size(field, 3) + ! TODO: These averages could potentially be modified to use the function in + ! the MOM_spatial_means module. + if (staggered_in_x .and. .not. staggered_in_y) then if (is_layer) then ! U-points @@ -591,30 +671,26 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, vol_sum(k) = 0. stuff_sum(k) = 0. if (is_extensive) then - do j=G%jsc, G%jec ; do i=G%isc, G%iec - v1 = G%areaCu(I,j) - v2 = G%areaCu(I-1,j) - vol_sum(k) = vol_sum(k) + 0.5 * ( v1 + v2 ) * G%mask2dT(i,j) - stuff_sum(k) = stuff_sum(k) + 0.5 * ( v1 * field(I,j,k) + v2 * field(I-1,j,k) ) * G%mask2dT(i,j) + do j=G%jsc, G%jec ; do I=G%isc, G%iec + I1 = I - G%isdB + 1 + volume(I,j,k) = G%areaCu(I,j) * G%mask2dCu(I,j) + stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) enddo ; enddo else ! Intensive - do j=G%jsc, G%jec ; do i=G%isc, G%iec - v1 = G%areaCu(I,j) * 0.5 * ( h(i,j,k) + h(i+1,j,k) ) - v2 = G%areaCu(I-1,j) * 0.5 * ( h(i,j,k) + h(i-1,j,k) ) - vol_sum(k) = vol_sum(k) + 0.5 * ( v1 + v2 ) * G%mask2dT(i,j) - stuff_sum(k) = stuff_sum(k) + 0.5 * ( v1 * field(I,j,k) + v2 * field(I-1,j,k) ) * G%mask2dT(i,j) + do j=G%jsc, G%jec ; do I=G%isc, G%iec + I1 = i - G%isdB + 1 + height = 0.5 * (h(i,j,k) + h(i+1,j,k)) + volume(I,j,k) = G%areaCu(I,j) * height * G%mask2dCu(I,j) + stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) enddo ; enddo endif enddo else ! Interface do k=1,nz - vol_sum(k) = 0. - stuff_sum(k) = 0. - do j=G%jsc, G%jec ; do i=G%isc, G%iec - v1 = G%areaCu(I,j) - v2 = G%areaCu(I-1,j) - vol_sum(k) = vol_sum(k) + 0.5 * ( v1 + v2 ) * G%mask2dT(i,j) - stuff_sum(k) = stuff_sum(k) + 0.5 * ( v1 * field(I,j,k) + v2 * field(I-1,j,k) ) * G%mask2dT(i,j) + do j=G%jsc, G%jec ; do I=G%isc, G%iec + I1 = I - G%isdB + 1 + volume(I,j,k) = G%areaCu(I,j) * G%mask2dCu(I,j) + stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) enddo ; enddo enddo endif @@ -622,33 +698,27 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, if (is_layer) then ! V-points do k=1,nz - vol_sum(k) = 0. - stuff_sum(k) = 0. if (is_extensive) then - do j=G%jsc, G%jec ; do i=G%isc, G%iec - v1 = G%areaCv(i,J) - v2 = G%areaCv(i,J-1) - vol_sum(k) = vol_sum(k) + 0.5 * ( v1 + v2 ) * G%mask2dT(i,j) - stuff_sum(k) = stuff_sum(k) + 0.5 * ( v1 * field(i,J,k) + v2 * field(i,J-1,k) ) * G%mask2dT(i,j) + do J=G%jsc, G%jec ; do i=G%isc, G%iec + J1 = J - G%jsdB + 1 + volume(i,J,k) = G%areaCv(i,J) * G%mask2dCv(i,J) + stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) enddo ; enddo else ! Intensive - do j=G%jsc, G%jec ; do i=G%isc, G%iec - v1 = G%areaCv(i,J) * 0.5 * ( h(i,j,k) + h(i,j+1,k) ) - v2 = G%areaCv(i,J-1) * 0.5 * ( h(i,j,k) + h(i,j-1,k) ) - vol_sum(k) = vol_sum(k) + 0.5 * ( v1 + v2 ) * G%mask2dT(i,j) - stuff_sum(k) = stuff_sum(k) + 0.5 * ( v1 * field(i,J,k) + v2 * field(i,J-1,k) ) * G%mask2dT(i,j) + do J=G%jsc, G%jec ; do i=G%isc, G%iec + J1 = J - G%jsdB + 1 + height = 0.5 * (h(i,j,k) + h(i,j+1,k)) + volume(i,J,k) = G%areaCv(i,J) * height * G%mask2dCv(i,J) + stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) enddo ; enddo endif enddo else ! Interface do k=1,nz - vol_sum(k) = 0. - stuff_sum(k) = 0. - do j=G%jsc, G%jec ; do i=G%isc, G%iec - v1 = G%areaCv(i,J) - v2 = G%areaCv(i,J-1) - vol_sum(k) = vol_sum(k) + 0.5 * ( v1 + v2 ) * G%mask2dT(i,j) - stuff_sum(k) = stuff_sum(k) + 0.5 * ( v1 * field(i,J,k) + v2 * field(i,J-1,k) ) * G%mask2dT(i,j) + do J=G%jsc, G%jec ; do i=G%isc, G%iec + J1 = J - G%jsdB + 1 + volume(i,J,k) = G%areaCv(i,J) * G%mask2dCv(i,J) + stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) enddo ; enddo enddo endif @@ -656,37 +726,28 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, if (is_layer) then ! H-points do k=1,nz - vol_sum(k) = 0. - stuff_sum(k) = 0. if (is_extensive) then do j=G%jsc, G%jec ; do i=G%isc, G%iec - if (G%mask2dT(i,j)>0. .and. h(i,j,k)>0.) then - v1 = G%areaT(i,j) - vol_sum(k) = vol_sum(k) + v1 - stuff_sum(k) = stuff_sum(k) + v1 * field(i,j,k) + if (h(i,j,k) > 0.) then + volume(i,j,k) = G%areaT(i,j) * G%mask2dT(i,j) + stuff(i,j,k) = volume(i,j,k) * field(i,j,k) + else + volume(i,j,k) = 0. + stuff(i,j,k) = 0. endif enddo ; enddo else ! Intensive do j=G%jsc, G%jec ; do i=G%isc, G%iec - if (G%mask2dT(i,j)>0. .and. h(i,j,k)>0.) then - v1 = G%areaT(i,j) * h(i,j,k) - vol_sum(k) = vol_sum(k) + v1 - stuff_sum(k) = stuff_sum(k) + v1 * field(i,j,k) - endif + volume(i,j,k) = G%areaT(i,j) * h(i,j,k) * G%mask2dT(i,j) + stuff(i,j,k) = volume(i,j,k) * field(i,j,k) enddo ; enddo endif enddo else ! Interface do k=1,nz - vol_sum(k) = 0. - stuff_sum(k) = 0. do j=G%jsc, G%jec ; do i=G%isc, G%iec - val = field(i,j,k) - if (G%mask2dT(i,j)>0. .and. val/=missing_value) then - v1 = G%areaT(i,j) - vol_sum(k) = vol_sum(k) + v1 - stuff_sum(k) = stuff_sum(k) + v1 * field(i,j,k) - endif + volume(i,j,k) = G%areaT(i,j) * G%mask2dT(i,j) + stuff(i,j,k) = volume(i,j,k) * field(i,j,k) enddo ; enddo enddo endif @@ -694,14 +755,18 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, call assert(.false., 'horizontally_average_diag_field: Q point averaging is not coded yet.') endif - call sum_across_PEs(vol_sum, nz) - call sum_across_PEs(stuff_sum, nz) + do k = 1,nz + vol_sum(k) = reproducing_sum(volume(:,:,k)) + stuff_sum(k) = reproducing_sum(stuff(:,:,k)) + enddo + averaged_mask(:) = .true. do k=1,nz - if (vol_sum(k)>0.) then + if (vol_sum(k) > 0.) then averaged_field(k) = stuff_sum(k) / vol_sum(k) else - averaged_field(k) = missing_value + averaged_field(k) = 0. + averaged_mask(k) = .false. endif enddo diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 36f43528be..75496544db 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -40,6 +40,7 @@ module MOM_document logical :: defineSyntax = .false. !< If true, use '\#def' syntax instead of a=b syntax logical :: warnOnConflicts = .false. !< Cause a WARNING error if defaults differ. integer :: commentColumn = 32 !< Number of spaces before the comment marker. + integer :: max_line_len = 112 !< The maximum length of message lines. type(link_msg), pointer :: chain_msg => NULL() !< Database of messages character(len=240) :: blockPrefix = '' !< The full name of the current block. end type doc_type @@ -457,9 +458,16 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & integer, optional, intent(in) :: indent !< An amount by which to indent this message logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. - character(len=mLen) :: mesg - integer :: start_ind = 1, end_ind, indnt, tab, len_tab, len_nl - logical :: all, short, layout, debug + + ! Local variables + character(len=mLen) :: mesg ! A full line of a message including indents. + character(len=mLen) :: mesg_text ! A line of message text without preliminary indents. + integer :: start_ind = 1 ! The starting index in the description for the next line. + integer :: nl_ind, tab_ind, end_ind ! The indices of new-lines, tabs, and the end of a line. + integer :: len_text, len_tab, len_nl ! The lengths of the text string, tabs and new-lines. + integer :: indnt, msg_pad ! Space counts used to format a message. + logical :: msg_done, reset_msg_pad ! Logicals used to format messages. + logical :: all, short, layout, debug ! Flags indicating which files to write into. layout = .false. ; if (present(layoutParam)) layout = layoutParam debug = .false. ; if (present(debuggingParam)) debug = debuggingParam @@ -475,41 +483,64 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & if (len_trim(desc) == 0) return len_tab = len_trim("_\t_") - 2 - len_nl = len_trim("_\n_") -2 + len_nl = len_trim("_\n_") - 2 indnt = doc%commentColumn ; if (present(indent)) indnt = indent - start_ind = 1 + len_text = doc%max_line_len - (indnt + 2) + start_ind = 1 ; msg_pad = 0 ; msg_done = .false. do if (len_trim(desc(start_ind:)) < 1) exit - end_ind = index(desc(start_ind:), "\n") + nl_ind = index(desc(start_ind:), "\n") - if (end_ind > 0) then - mesg = repeat(" ",indnt)//"! "//trim(desc(start_ind:start_ind+end_ind-2)) - start_ind = start_ind + end_ind - 1 + len_nl + end_ind = 0 + if ((nl_ind > 0) .and. (len_trim(desc(start_ind:start_ind+nl_ind-2)) > len_text-msg_pad)) then + ! This line is too long despite the new-line character. Look for an earlier space to break. + end_ind = scan(desc(start_ind:start_ind+(len_text-msg_pad)), " ", back=.true.) - 1 + if (end_ind > 0) nl_ind = 0 + elseif ((nl_ind == 0) .and. (len_trim(desc(start_ind:)) > len_text-msg_pad)) then + ! This line is too long and does not have a new-line character. Look for a space to break. + end_ind = scan(desc(start_ind:start_ind+(len_text-msg_pad)), " ", back=.true.) - 1 + endif - do ; tab = index(mesg, "\t") - if (tab == 0) exit - mesg(tab:) = " "//trim(mesg(tab+len_tab:)) - enddo - if (all) write(doc%unitAll, '(a)') trim(mesg) - if (short) write(doc%unitShort, '(a)') trim(mesg) - if (layout) write(doc%unitLayout, '(a)') trim(mesg) - if (debug) write(doc%unitDebugging, '(a)') trim(mesg) + reset_msg_pad = .false. + if (nl_ind > 0) then + mesg_text = trim(desc(start_ind:start_ind+nl_ind-2)) + start_ind = start_ind + nl_ind + len_nl - 1 + reset_msg_pad = .true. + elseif (end_ind > 0) then + mesg_text = trim(desc(start_ind:start_ind+end_ind)) + start_ind = start_ind + end_ind + 1 + ! Adjust the starting point to move past leading spaces. + start_ind = start_ind + (len_trim(desc(start_ind:)) - len_trim(adjustl(desc(start_ind:)))) else - mesg = repeat(" ",indnt)//"! "//trim(desc(start_ind:)) - do ; tab = index(mesg, "\t") - if (tab == 0) exit - mesg(tab:) = " "//trim(mesg(tab+len_tab:)) - enddo - if (all) write(doc%unitAll, '(a)') trim(mesg) - if (short) write(doc%unitShort, '(a)') trim(mesg) - if (layout) write(doc%unitLayout, '(a)') trim(mesg) - if (debug) write(doc%unitDebugging, '(a)') trim(mesg) - exit + mesg_text = trim(desc(start_ind:)) + msg_done = .true. endif + do ; tab_ind = index(mesg_text, "\t") ! Replace \t with 2 spaces. + if (tab_ind == 0) exit + mesg_text(tab_ind:) = " "//trim(mesg_text(tab_ind+len_tab:)) + enddo + + mesg = repeat(" ",indnt)//"! "//repeat(" ",msg_pad)//trim(mesg_text) + + if (reset_msg_pad) then + msg_pad = 0 + elseif (msg_pad == 0) then ! Indent continuation lines. + msg_pad = len_trim(mesg_text) - len_trim(adjustl(mesg_text)) + ! If already indented, indent an additional 2 spaces. + if (msg_pad >= 2) msg_pad = msg_pad + 2 + endif + + if (all) write(doc%unitAll, '(a)') trim(mesg) + if (short) write(doc%unitShort, '(a)') trim(mesg) + if (layout) write(doc%unitLayout, '(a)') trim(mesg) + if (debug) write(doc%unitDebugging, '(a)') trim(mesg) + + if (msg_done) exit enddo + end subroutine writeMessageAndDesc ! ---------------------------------------------------------------------- diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index e53ec98f5c..64fddfe7fc 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1267,7 +1267,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "If true, the domain is meridionally reentrant.", & default=.false.) call get_param(param_file, mdl, "TRIPOLAR_N", tripolar_N, & - "Use tripolar connectivity at the northern edge of the \n"//& + "Use tripolar connectivity at the northern edge of the "//& "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & default=.false.) @@ -1307,19 +1307,19 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ endif #endif call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", MOM_dom%symmetric, & - "If defined, the velocity point data domain includes \n"//& - "every face of the thickness points. In other words, \n"//& - "some arrays are larger than others, depending on where \n"//& - "they are on the staggered grid. Also, the starting \n"//& - "index of the velocity-point arrays is usually 0, not 1. \n"//& + "If defined, the velocity point data domain includes "//& + "every face of the thickness points. In other words, "//& + "some arrays are larger than others, depending on where "//& + "they are on the staggered grid. Also, the starting "//& + "index of the velocity-point arrays is usually 0, not 1. "//& "This can only be set at compile time.",& layoutParam=.true.) call get_param(param_file, mdl, "NONBLOCKING_UPDATES", MOM_dom%nonblocking_updates, & "If true, non-blocking halo updates may be used.", & default=.false., layoutParam=.true.) call get_param(param_file, mdl, "THIN_HALO_UPDATES", MOM_dom%thin_halo_updates, & - "If true, optional arguments may be used to specify the \n"//& - "The width of the halos that are updated with each call.", & + "If true, optional arguments may be used to specify the "//& + "the width of the halos that are updated with each call.", & default=.true., layoutParam=.true.) nihalo_dflt = 4 ; njhalo_dflt = 4 @@ -1327,24 +1327,24 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (present(NJHALO)) njhalo_dflt = NJHALO call log_param(param_file, mdl, "!STATIC_MEMORY_", is_static, & - "If STATIC_MEMORY_ is defined, the principle variables \n"//& - "will have sizes that are statically determined at \n"//& - "compile time. Otherwise the sizes are not determined \n"//& - "until run time. The STATIC option is substantially \n"//& - "faster, but does not allow the PE count to be changed \n"//& + "If STATIC_MEMORY_ is defined, the principle variables "//& + "will have sizes that are statically determined at "//& + "compile time. Otherwise the sizes are not determined "//& + "until run time. The STATIC option is substantially "//& + "faster, but does not allow the PE count to be changed "//& "at run time. This can only be set at compile time.",& layoutParam=.true.) call get_param(param_file, mdl, trim(nihalo_nm), MOM_dom%nihalo, & - "The number of halo points on each side in the \n"//& - "x-direction. With STATIC_MEMORY_ this is set as NIHALO_ \n"//& - "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ \n"//& + "The number of halo points on each side in the "//& + "x-direction. With STATIC_MEMORY_ this is set as NIHALO_ "//& + "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ "//& "the default is NIHALO_ in "//trim(inc_nm)//" (if defined) or 2.", & default=4, static_value=nihalo_dflt, layoutParam=.true.) call get_param(param_file, mdl, trim(njhalo_nm), MOM_dom%njhalo, & - "The number of halo points on each side in the \n"//& - "y-direction. With STATIC_MEMORY_ this is set as NJHALO_ \n"//& - "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ \n"//& + "The number of halo points on each side in the "//& + "y-direction. With STATIC_MEMORY_ this is set as NJHALO_ "//& + "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ "//& "the default is NJHALO_ in "//trim(inc_nm)//" (if defined) or 2.", & default=4, static_value=njhalo_dflt, layoutParam=.true.) if (present(min_halo)) then @@ -1357,13 +1357,13 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif if (is_static) then call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & - "The total number of thickness grid points in the \n"//& - "x-direction in the physical domain. With STATIC_MEMORY_ \n"//& + "The total number of thickness grid points in the "//& + "x-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & static_value=NIGLOBAL) call get_param(param_file, mdl, "NJGLOBAL", MOM_dom%njglobal, & - "The total number of thickness grid points in the \n"//& - "y-direction in the physical domain. With STATIC_MEMORY_ \n"//& + "The total number of thickness grid points in the "//& + "y-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & static_value=NJGLOBAL) if (MOM_dom%niglobal /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & @@ -1379,13 +1379,13 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif else call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & - "The total number of thickness grid points in the \n"//& - "x-direction in the physical domain. With STATIC_MEMORY_ \n"//& + "The total number of thickness grid points in the "//& + "x-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & fail_if_missing=.true.) call get_param(param_file, mdl, "NJGLOBAL", MOM_dom%njglobal, & - "The total number of thickness grid points in the \n"//& - "y-direction in the physical domain. With STATIC_MEMORY_ \n"//& + "The total number of thickness grid points in the "//& + "y-direction in the physical domain. With STATIC_MEMORY_ "//& "this is set in "//trim(inc_nm)//" at compile time.", & fail_if_missing=.true.) endif @@ -1397,15 +1397,15 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & inputdir = slasher(inputdir) call get_param(param_file, mdl, trim(masktable_nm), mask_table, & - "A text file to specify n_mask, layout and mask_list. \n"//& - "This feature masks out processors that contain only land points. \n"//& - "The first line of mask_table is the number of regions to be masked out.\n"//& - "The second line is the layout of the model and must be \n"//& - "consistent with the actual model layout.\n"//& - "The following (n_mask) lines give the logical positions \n"//& - "of the processors that are masked out. The mask_table \n"//& - "can be created by tools like check_mask. The \n"//& - "following example of mask_table masks out 2 processors, \n"//& + "A text file to specify n_mask, layout and mask_list. "//& + "This feature masks out processors that contain only land points. "//& + "The first line of mask_table is the number of regions to be masked out. "//& + "The second line is the layout of the model and must be "//& + "consistent with the actual model layout. "//& + "The following (n_mask) lines give the logical positions "//& + "of the processors that are masked out. The mask_table "//& + "can be created by tools like check_mask. The "//& + "following example of mask_table masks out 2 processors, "//& "(1,2) and (3,6), out of the 24 in a 4x6 layout: \n"//& " 2\n 4,6\n 1,2\n 3,6\n", default="MOM_mask_table", & layoutParam=.true.) @@ -1416,7 +1416,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & layout(1) = NIPROC ; layout(2) = NJPROC else call get_param(param_file, mdl, trim(layout_nm), layout, & - "The processor layout to be used, or 0, 0 to automatically \n"//& + "The processor layout to be used, or 0, 0 to automatically "//& "set the layout based on the number of processors.", default=0, & do_not_log=.true.) call get_param(param_file, mdl, trim(niproc_nm), nip_parsed, & @@ -1455,11 +1455,11 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif endif call log_param(param_file, mdl, trim(niproc_nm), layout(1), & - "The number of processors in the x-direction. With \n"//& + "The number of processors in the x-direction. With "//& "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& layoutParam=.true.) call log_param(param_file, mdl, trim(njproc_nm), layout(2), & - "The number of processors in the y-direction. With \n"//& + "The number of processors in the y-direction. With "//& "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& layoutParam=.true.) call log_param(param_file, mdl, trim(layout_nm), layout, & @@ -1484,7 +1484,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! number of PEs in each direction. io_layout(:) = (/ 1, 1 /) call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & - "The processor layout to be used, or 0,0 to automatically \n"//& + "The processor layout to be used, or 0,0 to automatically "//& "set the io_layout to be the same as the layout.", default=1, & layoutParam=.true.) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 5c80fb9d51..1d1e153ab9 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -275,26 +275,26 @@ subroutine close_param_file(CS, quiet_close, component) "If true, all log messages are also sent to stdout.", & default=log_to_stdout_default) call log_param(CS, mdl, "REPORT_UNUSED_PARAMS", CS%report_unused, & - "If true, report any parameter lines that are not used \n"//& + "If true, report any parameter lines that are not used "//& "in the run.", default=report_unused_default, & debuggingParam=.true.) call log_param(CS, mdl, "FATAL_UNUSED_PARAMS", CS%unused_params_fatal, & - "If true, kill the run if there are any unused \n"//& + "If true, kill the run if there are any unused "//& "parameters.", default=unused_params_fatal_default, & debuggingParam=.true.) docfile_default = "MOM_parameter_doc" if (present(component)) docfile_default = trim(component)//"_parameter_doc" call log_param(CS, mdl, "DOCUMENT_FILE", CS%doc_file, & - "The basename for files where run-time parameters, their\n"//& - "settings, units and defaults are documented. Blank will\n"//& + "The basename for files where run-time parameters, their "//& + "settings, units and defaults are documented. Blank will "//& "disable all parameter documentation.", default=docfile_default) if (len_trim(CS%doc_file) > 0) then call log_param(CS, mdl, "COMPLETE_DOCUMENTATION", CS%complete_doc, & - "If true, all run-time parameters are\n"//& + "If true, all run-time parameters are "//& "documented in "//trim(CS%doc_file)//& ".all .", default=complete_doc_default) call log_param(CS, mdl, "MINIMAL_DOCUMENTATION", CS%minimal_doc, & - "If true, non-default run-time parameters are\n"//& + "If true, non-default run-time parameters are "//& "documented in "//trim(CS%doc_file)//& ".short .", default=minimal_doc_default) endif diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 9f1b645604..c3819fc865 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1439,7 +1439,7 @@ subroutine restart_init(param_file, CS, restart_root) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", & CS%parallel_restartfiles, & - "If true, each processor writes its own restart file, \n"//& + "If true, each processor writes its own restart file, "//& "otherwise a single restart file is generated", & default=.false.) @@ -1451,16 +1451,16 @@ subroutine restart_init(param_file, CS, restart_root) "The name-root of the restart file.", default="MOM.res") endif call get_param(param_file, mdl, "LARGE_FILE_SUPPORT", CS%large_file_support, & - "If true, use the file-size limits with NetCDF large \n"//& + "If true, use the file-size limits with NetCDF large "//& "file support (4Gb), otherwise the limit is 2Gb.", & default=.true.) call get_param(param_file, mdl, "MAX_FIELDS", CS%max_fields, & "The maximum number of restart fields that can be used.", & default=100) call get_param(param_file, mdl, "RESTART_CHECKSUMS_REQUIRED", CS%checksum_required, & - "If true, require the restart checksums to match and error out otherwise. \n"//& - "Users may want to avoid this comparison if for example the restarts are \n"//& - "made from a run with a different mask_table than the current run, \n"//& + "If true, require the restart checksums to match and error out otherwise. "//& + "Users may want to avoid this comparison if for example the restarts are "//& + "made from a run with a different mask_table than the current run, "//& "in which case the checksums will not match and cause crash.",& default=.true.) diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 60b07c1fbd..ca174025bf 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -58,15 +58,15 @@ subroutine unit_scaling_init( param_file, US ) call log_version(param_file, mdl, version, & "Parameters for doing unit scaling of variables.") call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & - "An integer power of 2 that is used to rescale the model's \n"//& + "An integer power of 2 that is used to rescale the model's "//& "intenal units of depths and heights. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & - "An integer power of 2 that is used to rescale the model's \n"//& + "An integer power of 2 that is used to rescale the model's "//& "intenal units of lateral distances. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & - "An integer power of 2 that is used to rescale the model's \n"//& + "An integer power of 2 that is used to rescale the model's "//& "intenal units of time. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index c85e3ecb7b..7a2fb36608 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -73,13 +73,13 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, & - "The maximum amount of cpu time per processor for which \n"//& - "MOM should run before saving a restart file and \n"//& - "quitting with a return value that indicates that a \n"//& - "further run is required to complete the simulation. \n"//& - "If automatic restarts are not desired, use a negative \n"//& - "value for MAXCPU. MAXCPU has units of wall-clock \n"//& - "seconds, so the actual CPU time used is larger by a \n"//& + "The maximum amount of cpu time per processor for which "//& + "MOM should run before saving a restart file and "//& + "quitting with a return value that indicates that a "//& + "further run is required to complete the simulation. "//& + "If automatic restarts are not desired, use a negative "//& + "value for MAXCPU. MAXCPU has units of wall-clock "//& + "seconds, so the actual CPU time used is larger by a "//& "factor of the number of processors used.", & units="wall-clock seconds", default=-1.0) call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, & diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 43987f8f63..e8f1fecf60 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1170,15 +1170,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl default=.false.) if (shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", CS%override_shelf_movement, & - "If true, user provided code specifies the ice-shelf \n"//& + "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false.) CS%active_shelf_dynamics = .not.CS%override_shelf_movement call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & - "If true, regularize the floatation condition at the \n"//& + "If true, regularize the floatation condition at the "//& "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & - "If true, let the floatation condition be determined by \n"//& - "ocean column thickness. This means that update_OD_ffrac \n"//& + "If true, let the floatation condition be determined by "//& + "ocean column thickness. This means that update_OD_ffrac "//& "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. @@ -1188,24 +1188,24 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "If true, use a thermodynamically interactive ice shelf.", & default=.false.) call get_param(param_file, mdl, "SHELF_THREE_EQN", CS%threeeq, & - "If true, use the three equation expression of \n"//& - "consistency to calculate the fluxes at the ice-ocean \n"//& + "If true, use the three equation expression of "//& + "consistency to calculate the fluxes at the ice-ocean "//& "interface.", default=.true.) call get_param(param_file, mdl, "SHELF_INSULATOR", CS%insulator, & - "If true, the ice shelf is a perfect insulatior \n"//& + "If true, the ice shelf is a perfect insulatior "//& "(no conduction).", default=.false.) call get_param(param_file, mdl, "MELTING_CUTOFF_DEPTH", CS%cutoff_depth, & - "Depth above which the melt is set to zero (it must be >= 0) \n"//& + "Depth above which the melt is set to zero (it must be >= 0) "//& "Default value won't affect the solution.", default=0.0) if (CS%cutoff_depth < 0.) & call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") call get_param(param_file, mdl, "CONST_SEA_LEVEL", CS%constant_sea_level, & - "If true, apply evaporative, heat and salt fluxes in \n"//& - "the sponge region. This will avoid a large increase \n"//& - "in sea level. This option is needed for some of the \n"//& - "ISOMIP+ experiments (Ocean3 and Ocean4). \n"//& - "IMPORTANT: it is not currently possible to do \n"//& + "If true, apply evaporative, heat and salt fluxes in "//& + "the sponge region. This will avoid a large increase "//& + "in sea level. This option is needed for some of the "//& + "ISOMIP+ experiments (Ocean3 and Ocean4). "//& + "IMPORTANT: it is not currently possible to do "//& "prefect restarts using this flag.", default=.false.) call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", & @@ -1217,8 +1217,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl default=-1.9, do_not_log=.true.) call get_param(param_file, mdl, "SHELF_3EQ_GAMMA", CS%const_gamma, & - "If true, user specifies a constant nondimensional heat-transfer coefficient \n"//& - "(GAMMA_T_3EQ), from which the salt-transfer coefficient is then computed \n"//& + "If true, user specifies a constant nondimensional heat-transfer coefficient "//& + "(GAMMA_T_3EQ), from which the salt-transfer coefficient is then computed "//& " as GAMMA_T_3EQ/35. This is used with SHELF_THREE_EQN.", default=.false.) if (CS%const_gamma) call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_T", CS%Gamma_T_3EQ, & "Nondimensional heat-transfer coefficient.",default=2.2E-2, & @@ -1230,19 +1230,19 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (CS%threeeq) & call get_param(param_file, mdl, "SHELF_S_ROOT", CS%find_salt_root, & - "If SHELF_S_ROOT = True, salinity at the ice/ocean interface (Sbdry) \n "//& - "is computed from a quadratic equation. Otherwise, the previous \n"//& + "If SHELF_S_ROOT = True, salinity at the ice/ocean interface (Sbdry) "//& + "is computed from a quadratic equation. Otherwise, the previous "//& "interactive method to estimate Sbdry is used.", default=.false.) if (CS%find_salt_root) then ! read liquidus coeffs. call get_param(param_file, mdl, "TFREEZE_S0_P0",CS%lambda1, & - "this is the freezing potential temperature at \n"//& + "this is the freezing potential temperature at "//& "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DS",CS%lambda1, & - "this is the derivative of the freezing potential \n"//& + "this is the derivative of the freezing potential "//& "temperature with salinity.", & units="degC psu-1", default=-0.054, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DP",CS%lambda3, & - "this is the derivative of the freezing potential \n"//& + "this is the derivative of the freezing potential "//& "temperature with pressure.", & units="degC Pa-1", default=0.0, do_not_log=.true.) @@ -1250,7 +1250,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (.not.CS%threeeq) & call get_param(param_file, mdl, "SHELF_2EQ_GAMMA_T", CS%gamma_t, & - "If SHELF_THREE_EQN is false, this the fixed turbulent \n"//& + "If SHELF_THREE_EQN is false, this the fixed turbulent "//& "exchange velocity at the ice-ocean interface.", & units="m s-1", fail_if_missing=.true.) @@ -1261,9 +1261,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The heat capacity of sea water.", units="J kg-1 K-1", & fail_if_missing=.true.) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) !### MAKE THIS A SEPARATE PARAMETER. call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & @@ -1271,13 +1271,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl default=2.10e3) call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & - "Non-dimensional factor applied to shelf thermodynamic \n"//& + "Non-dimensional factor applied to shelf thermodynamic "//& "fluxes.", units="none", default=1.0) call get_param(param_file, mdl, "KV_ICE", CS%kv_ice, & "The viscosity of the ice.", units="m2 s-1", default=1.0e10) call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & - "The molecular kinimatic viscosity of sea water at the \n"//& + "The molecular kinimatic viscosity of sea water at the "//& "freezing temperature.", units="m2 s-1", default=1.95e-6) call get_param(param_file, mdl, "ICE_SHELF_SALINITY", CS%Salin_ice, & "The salinity of the ice inside the ice shelf.", units="psu", & @@ -1286,17 +1286,17 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The temperature at the center of the ice shelf.", & units = "degC", default=-15.0) call get_param(param_file, mdl, "KD_SALT_MOLECULAR", CS%kd_molec_salt, & - "The molecular diffusivity of salt in sea water at the \n"//& + "The molecular diffusivity of salt in sea water at the "//& "freezing point.", units="m2 s-1", default=8.02e-10) call get_param(param_file, mdl, "KD_TEMP_MOLECULAR", CS%kd_molec_temp, & - "The molecular diffusivity of heat in sea water at the \n"//& + "The molecular diffusivity of heat in sea water at the "//& "freezing point.", units="m2 s-1", default=1.41e-7) call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & "avg ocean density used in floatation cond", & units="kg m-3", default=1035.) call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & - "The time step for changing forcing, coupling with other \n"//& - "components, or potentially writing certain diagnostics. \n"//& + "The time step for changing forcing, coupling with other "//& + "components, or potentially writing certain diagnostics. "//& "The default value is given by DT.", units="s", default=0.0) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", CS%col_thick_melt_threshold, & @@ -1304,14 +1304,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl default=0.0) call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & - "If true, read a file (given by TIDEAMP_FILE) containing \n"//& + "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) call safe_alloc_ptr(CS%utide,isd,ied,jsd,jed) ; CS%utide(:,:) = 0.0 if (read_TIDEAMP) then call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & - "The path to the file containing the spatially varying \n"//& + "The path to the file containing the spatially varying "//& "tidal amplitudes.", & default="tideamp.nc") call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -1353,15 +1353,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The minimum value of ustar under ice sheves.", & units="m s-1", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "CDRAG_SHELF", cdrag, & - "CDRAG is the drag coefficient relating the magnitude of \n"//& + "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the surface stress.", units="nondim", & default=0.003) CS%cdrag = cdrag if (CS%ustar_bg <= 0.0) then call get_param(param_file, mdl, "DRAG_BG_VEL_SHELF", drag_bg_vel, & - "DRAG_BG_VEL is either the assumed bottom velocity (with \n"//& - "LINEAR_DRAG) or an unresolved velocity that is \n"//& - "combined with the resolved velocity to estimate the \n"//& + "DRAG_BG_VEL is either the assumed bottom velocity (with "//& + "LINEAR_DRAG) or an unresolved velocity that is "//& + "combined with the resolved velocity to estimate the "//& "velocity magnitude.", units="m s-1", default=0.0, scale=US%m_to_Z) if (CS%cdrag*drag_bg_vel > 0.0) CS%ustar_bg = sqrt(CS%cdrag)*drag_bg_vel endif @@ -1536,7 +1536,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "If true, save the ice shelf initial conditions.", & default=.false.) if (save_IC) call get_param(param_file, mdl, "SHELF_IC_OUTPUT_FILE", IC_file,& - "The name-root of the output file for the ice shelf \n"//& + "The name-root of the output file for the ice shelf "//& "initial conditions.", default="MOM_Shelf_IC") if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & @@ -1606,7 +1606,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) new_sim_2 = .true. ; if (present(new_sim)) new_sim_2 = new_sim call get_param(param_file, mdl, "ICE_SHELF_CONFIG", config, & - "A string that specifies how the ice shelf is \n"//& + "A string that specifies how the ice shelf is "//& "initialized. Valid options include:\n"//& " \tfile\t Read from a file.\n"//& " \tzero\t Set shelf mass to 0 everywhere.\n"//& @@ -1622,8 +1622,8 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) inputdir = slasher(inputdir) call get_param(param_file, mdl, "SHELF_FILE", shelf_file, & - "If DYNAMIC_SHELF_MASS = True, OVERRIDE_SHELF_MOVEMENT = True \n"//& - "and ICE_SHELF_MASS_FROM_FILE = True, this is the file from \n"//& + "If DYNAMIC_SHELF_MASS = True, OVERRIDE_SHELF_MOVEMENT = True "//& + "and ICE_SHELF_MASS_FROM_FILE = True, this is the file from "//& "which to read the shelf mass and area.", & default="shelf_mass.nc") call get_param(param_file, mdl, "SHELF_MASS_VAR", shelf_mass_var, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 3826466d30..415ae3d813 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -225,7 +225,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) default=.false., do_not_log=.true.) if (shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & - "If true, user provided code specifies the ice-shelf \n"//& + "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) active_shelf_dynamics = .not.override_shelf_movement endif @@ -312,29 +312,29 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ override_shelf_movement = .false. ; active_shelf_dynamics = .false. if (shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & - "If true, user provided code specifies the ice-shelf \n"//& + "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) active_shelf_dynamics = .not.override_shelf_movement call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & - "If true, regularize the floatation condition at the \n"//& + "If true, regularize the floatation condition at the "//& "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", CS%n_sub_regularize, & - "The number of sub-partitions of each cell over which to \n"//& - "integrate for the interpolated grounding line. Each cell \n"//& - "is divided into NxN equally-sized rectangles, over which the \n"//& + "The number of sub-partitions of each cell over which to "//& + "integrate for the interpolated grounding line. Each cell "//& + "is divided into NxN equally-sized rectangles, over which the "//& "basal contribution is integrated by iterative quadrature.", & default=0) call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & - "If true, let the floatation condition be determined by \n"//& - "ocean column thickness. This means that update_OD_ffrac \n"//& + "If true, let the floatation condition be determined by "//& + "ocean column thickness. This means that update_OD_ffrac "//& "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & - "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). \n"// & + "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). "//& "This is only used with an ice-only model.", default=0.25) endif call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & @@ -372,14 +372,14 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & "max iteratiions in CG solver", default=2000) call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & - "min ocean thickness to consider ice *floating*; \n"// & + "min ocean thickness to consider ice *floating*; "//& "will only be important with use of tides", & units="m", default=1.e-3, scale=US%m_to_Z) call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & - "Choose whether nonlin error in vel solve is based on nonlinear \n"// & + "Choose whether nonlin error in vel solve is based on nonlinear "//& "residual (1) or relative change since last iteration (2)", default=1) call get_param(param_file, mdl, "SHELF_DYN_REPRODUCING_SUMS", CS%use_reproducing_sums, & - "If true, use the reproducing extended-fixed-point sums in \n"//& + "If true, use the reproducing extended-fixed-point sums in "//& "the ice shelf dynamics solvers.", default=.true.) call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 945b634e91..bc00ac61a9 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -42,7 +42,7 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, PF) character(len=200) :: config call get_param(PF, mdl, "ICE_PROFILE_CONFIG", config, & - "This specifies how the initial ice profile is specified. \n"//& + "This specifies how the initial ice profile is specified. "//& "Valid values are: CHANNEL, FILE, and USER.", & fail_if_missing=.true.) @@ -180,9 +180,9 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, call get_param(PF, mdl, "SHELF_EDGE_POS_0", edge_pos, & units="axis_units", default=0.0) ! call get_param(param_file, mdl, "RHO_0", Rho_ocean, & -! "The mean ocean density used with BOUSSINESQ true to \n"//& -! "calculate accelerations and the mass for conservation \n"//& -! "properties, or with BOUSSINSEQ false to convert some \n"//& +! "The mean ocean density used with BOUSSINESQ true to "//& +! "calculate accelerations and the mass for conservation "//& +! "properties, or with BOUSSINSEQ false to convert some "//& ! "parameters from vertical units of m to kg m-2.", & ! units="kg m-3", default=1035.0, scale=US%Z_to_m) @@ -272,11 +272,11 @@ end subroutine initialize_ice_thickness_channel ! logical flux_bdry ! call get_param(PF, mdl, "ICE_BOUNDARY_CONFIG", config, & -! "This specifies how the ice domain boundary is specified. \n"//& +! "This specifies how the ice domain boundary is specified. "//& ! "valid values include CHANNEL, FILE and USER.", & ! fail_if_missing=.true.) ! call get_param(PF, mdl, "ICE_BOUNDARY_FLUX_CONDITION", flux_bdry, & -! "This specifies whether mass input is a dirichlet or \n"//& +! "This specifies whether mass input is a dirichlet or "//& ! "flux condition", default=.true.) ! select case ( trim(config) ) diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index d4e83561a7..5505154d23 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -185,8 +185,7 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) character(len=40) :: mdl = "MOM_marine_ice" ! This module's name. if (associated(CS)) then - call MOM_error(WARNING, "marine_ice_init called with an "// & - "associated control structure.") + call MOM_error(WARNING, "marine_ice_init called with an associated control structure.") return else ; allocate(CS) ; endif @@ -200,8 +199,8 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", units="J/kg", default=hlf) call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & - "Fraction of grid cell which iceberg must occupy, so that fluxes \n"//& - "below berg are set to zero. Not applied for negative \n"//& + "Fraction of grid cell which iceberg must occupy, so that fluxes "//& + "below berg are set to zero. Not applied for negative "//& "values.", units="non-dim", default=-1.0) end subroutine marine_ice_init diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 2829f712e0..ec2787bae3 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -77,9 +77,9 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, if (CS%first_call) call write_user_log(param_file) CS%first_call = .false. call get_param(param_file, mdl, "RHO_0", CS%Rho_ocean, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%Z_to_m) call get_param(param_file, mdl, "SHELF_MAX_DRAFT", CS%max_draft, & diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 8899627cc7..d497a7828e 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -275,7 +275,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & "The reduced gravity at the free surface.", units="m s-2", & default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) call get_param(param_file, mdl, "COORD_FILE", coord_file, & - "The file from which the coordinate temperatures and \n"//& + "The file from which the coordinate temperatures and "//& "salinities are read.", fail_if_missing=.true.) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -330,25 +330,25 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & call get_param(param_file, mdl, "T_REF", T_Ref, & "The default initial temperatures.", units="degC", default=10.0) call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_Light, & - "The initial temperature of the lightest layer when \n"//& + "The initial temperature of the lightest layer when "//& "COORD_CONFIG is set to ts_range.", units="degC", default=T_Ref) call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_Dense, & - "The initial temperature of the densest layer when \n"//& + "The initial temperature of the densest layer when "//& "COORD_CONFIG is set to ts_range.", units="degC", default=T_Ref) call get_param(param_file, mdl, "S_REF", S_Ref, & "The default initial salinities.", units="PSU", default=35.0) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_Light, & - "The initial lightest salinities when COORD_CONFIG \n"//& + "The initial lightest salinities when COORD_CONFIG "//& "is set to ts_range.", default = S_Ref, units="PSU") call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_Dense, & - "The initial densest salinities when COORD_CONFIG \n"//& + "The initial densest salinities when COORD_CONFIG "//& "is set to ts_range.", default = S_Ref, units="PSU") call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & - "The ratio of density space resolution in the densest \n"//& - "part of the range to that in the lightest part of the \n"//& - "range when COORD_CONFIG is set to ts_range. Values \n"//& + "The ratio of density space resolution in the densest "//& + "part of the range to that in the lightest part of the "//& + "range when COORD_CONFIG is set to ts_range. Values "//& "greater than 1 increase the resolution of the denser water.",& default=1.0, units="nondim") @@ -408,7 +408,7 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) "The file from which the coordinate densities are read.", & fail_if_missing=.true.) call get_param(param_file, mdl, "COORD_VAR", coord_var, & - "The variable in COORD_FILE that is to be used for the \n"//& + "The variable in COORD_FILE that is to be used for the "//& "coordinate densities.", default="Layer") filename = trim(inputdir)//trim(coord_file) call log_param(param_file, mdl, "INPUTDIR/COORD_FILE", filename) @@ -449,11 +449,11 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & - "The reference potential density used for the surface \n"// & - "interface.", units="kg m-3", default=GV%Rho0) + "The reference potential density used for the surface interface.", & + units="kg m-3", default=GV%Rho0) call get_param(param_file, mdl, "DENSITY_RANGE", Rlay_range, & - "The range of reference potential densities across \n"// & - "all interfaces.", units="kg m-3", default=2.0) + "The range of reference potential densities across all interfaces.", & + units="kg m-3", default=2.0) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index f51676bd1b..71d9c4f90b 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -134,7 +134,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) ! This call sets the topography at velocity points. if (G%bathymetry_at_vel) then call get_param(PF, mdl, "VELOCITY_DEPTH_CONFIG", config, & - "A string that determines how the topography is set at \n"//& + "A string that determines how the topography is set at "//& "velocity points. This may be 'min' or 'max'.", & default="max") select case ( trim(config) ) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 3da13a3063..305087dc44 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -72,7 +72,7 @@ subroutine set_grid_metrics(G, param_file, US) call callTree_enter("set_grid_metrics(), MOM_grid_initialize.F90") call log_version(param_file, "MOM_grid_init", version, "") call get_param(param_file, "MOM_grid_init", "GRID_CONFIG", config, & - "A character string that determines the method for \n"//& + "A character string that determines the method for "//& "defining the horizontal grid. Current options are: \n"//& " \t mosaic - read the grid from a mosaic (supergrid) \n"//& " \t file set by GRID_FILE.\n"//& @@ -202,7 +202,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) "Name of the file from which to read horizontal grid data.", & fail_if_missing=.true.) call get_param(param_file, mdl, "USE_TRIPOLAR_GEOLONB_BUG", lon_bug, & - "If true, use older code that incorrectly sets the longitude \n"//& + "If true, use older code that incorrectly sets the longitude "//& "in some points along the tripolar fold to be off by 360 degrees.", & default=.true.) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -443,14 +443,14 @@ subroutine set_grid_metrics_cartesian(G, param_file) " \t degrees - degrees of latitude and longitude \n"//& " \t m - meters \n \t k - kilometers", default="degrees") call get_param(param_file, mdl, "SOUTHLAT", G%south_lat, & - "The southern latitude of the domain or the equivalent \n"//& + "The southern latitude of the domain or the equivalent "//& "starting value for the y-axis.", units=units_temp, & fail_if_missing=.true.) call get_param(param_file, mdl, "LENLAT", G%len_lat, & "The latitudinal or y-direction length of the domain.", & units=units_temp, fail_if_missing=.true.) call get_param(param_file, mdl, "WESTLON", G%west_lon, & - "The western longitude of the domain or the equivalent \n"//& + "The western longitude of the domain or the equivalent "//& "starting value for the x-axis.", units=units_temp, & default=0.0) call get_param(param_file, mdl, "LENLON", G%len_lon, & @@ -746,24 +746,24 @@ subroutine set_grid_metrics_mercator(G, param_file) G%west_lon = GP%west_lon ; G%len_lon = GP%len_lon G%Rad_Earth = GP%Rad_Earth call get_param(param_file, mdl, "ISOTROPIC", GP%isotropic, & - "If true, an isotropic grid on a sphere (also known as \n"//& - "a Mercator grid) is used. With an isotropic grid, the \n"//& - "meridional extent of the domain (LENLAT), the zonal \n"//& - "extent (LENLON), and the number of grid points in each \n"//& - "direction are _not_ independent. In MOM the meridional \n"//& - "extent is determined to fit the zonal extent and the \n"//& + "If true, an isotropic grid on a sphere (also known as "//& + "a Mercator grid) is used. With an isotropic grid, the "//& + "meridional extent of the domain (LENLAT), the zonal "//& + "extent (LENLON), and the number of grid points in each "//& + "direction are _not_ independent. In MOM the meridional "//& + "extent is determined to fit the zonal extent and the "//& "number of grid points, while grid is perfectly isotropic.", & default=.false.) call get_param(param_file, mdl, "EQUATOR_REFERENCE", GP%equator_reference, & - "If true, the grid is defined to have the equator at the \n"//& + "If true, the grid is defined to have the equator at the "//& "nearest q- or h- grid point to (-LOWLAT*NJGLOBAL/LENLAT).", & default=.true.) call get_param(param_file, mdl, "LAT_ENHANCE_FACTOR", GP%Lat_enhance_factor, & - "The amount by which the meridional resolution is \n"//& + "The amount by which the meridional resolution is "//& "enhanced within LAT_EQ_ENHANCE of the equator.", & units="nondim", default=1.0) call get_param(param_file, mdl, "LAT_EQ_ENHANCE", GP%Lat_eq_enhance, & - "The latitude range to the north and south of the equator \n"//& + "The latitude range to the north and south of the equator "//& "over which the resolution is enhanced.", units="degrees", & default=0.0) @@ -1236,13 +1236,13 @@ subroutine initialize_masks(G, PF, US) call callTree_enter("initialize_masks(), MOM_grid_initialize.F90") m_to_Z_scale = 1.0 ; if (present(US)) m_to_Z_scale = US%m_to_Z call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & - "If MASKING_DEPTH is unspecified, then anything shallower than\n"//& - "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out.\n"//& - "If MASKING_DEPTH is specified, then all depths shallower than\n"//& + "If MASKING_DEPTH is unspecified, then anything shallower than "//& + "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out. "//& + "If MASKING_DEPTH is specified, then all depths shallower than "//& "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & units="m", default=0.0, scale=m_to_Z_scale) call get_param(PF, mdl, "MASKING_DEPTH", mask_depth, & - "The depth below which to mask points as land points, for which all\n"//& + "The depth below which to mask points as land points, for which all "//& "fluxes are zeroed out. MASKING_DEPTH is ignored if negative.", & units="m", default=-9999.0, scale=m_to_Z_scale) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 2f9b1cefcc..42e99f2ef6 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -72,7 +72,7 @@ subroutine MOM_initialize_rotation(f, G, PF, US) "This specifies how the Coriolis parameter is specified: \n"//& " \t 2omegasinlat - Use twice the planetary rotation rate \n"//& " \t\t times the sine of latitude.\n"//& - " \t betaplane - Use a beta-plane or f-plane. \n"//& + " \t betaplane - Use a beta-plane or f-plane.\n"//& " \t USER - call a user modified routine.", & default="2omegasinlat") select case (trim(config)) @@ -349,7 +349,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth ! call get_param(param_file, mdl, "RAD_EARTH", Rad_Earth, & ! "The radius of the Earth.", units="m", default=6.378e6) call get_param(param_file, mdl, "TOPOG_SLOPE_SCALE", expdecay, & - "The exponential decay scale used in defining some of \n"//& + "The exponential decay scale used in defining some of "//& "the named topographies.", units="m", default=400000.0) endif @@ -426,9 +426,9 @@ subroutine limit_topography(D, G, param_file, max_depth, US) m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "If MASKING_DEPTH is unspecified, then anything shallower than\n"//& - "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out.\n"//& - "If MASKING_DEPTH is specified, then all depths shallower than\n"//& + "If MASKING_DEPTH is unspecified, then anything shallower than "//& + "MINIMUM_DEPTH is assumed to be land and all fluxes are masked out. "//& + "If MASKING_DEPTH is specified, then all depths shallower than "//& "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & units="m", default=0.0, scale=m_to_Z) call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, & @@ -511,10 +511,10 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) T_to_s = 1.0 ; if (present(US)) T_to_s = US%T_to_s call get_param(param_file, mdl, "F_0", f_0, & - "The reference value of the Coriolis parameter with the \n"//& + "The reference value of the Coriolis parameter with the "//& "betaplane option.", units="s-1", default=0.0, scale=T_to_s) call get_param(param_file, mdl, "BETA", beta, & - "The northward gradient of the Coriolis parameter with \n"//& + "The northward gradient of the Coriolis parameter with "//& "the betaplane option.", units="m-1 s-1", default=0.0, scale=T_to_s) call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") @@ -554,8 +554,8 @@ subroutine initialize_grid_rotation_angle(G, PF) integer :: i, j, m, n call get_param(PF, mdl, "GRID_ROTATION_ANGLE_BUGS", use_bugs, & - "If true, use an older algorithm to calculate the sine and \n"//& - "cosines needed rotate between grid-oriented directions and \n"//& + "If true, use an older algorithm to calculate the sine and "//& + "cosines needed rotate between grid-oriented directions and "//& "true north and east. Differences arise at the tripolar fold.", & default=.True.) @@ -842,7 +842,7 @@ subroutine reset_face_lengths_list(G, param_file, US) filename = trim(inputdir)//trim(chan_file) call log_param(param_file, mdl, "INPUTDIR/CHANNEL_LIST_FILE", filename) call get_param(param_file, mdl, "CHANNEL_LIST_360_LON_CHECK", check_360, & - "If true, the channel configuration list works for any \n"//& + "If true, the channel configuration list works for any "//& "longitudes in the range of -360 to 360.", default=.true.) if (is_root_pe()) then @@ -1241,7 +1241,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) out_q(:,:) = 0.0 call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", multiple_files, & - "If true, each processor writes its own restart file, \n"//& + "If true, each processor writes its own restart file, "//& "otherwise a single restart file is generated", & default=.false.) file_threading = SINGLE_FILE diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 32e7161b1e..aec93f0942 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -52,6 +52,7 @@ module MOM_state_initialization use ISOMIP_initialization, only : ISOMIP_initialize_thickness use ISOMIP_initialization, only : ISOMIP_initialize_sponges use ISOMIP_initialization, only : ISOMIP_initialize_temperature_salinity +use RGC_initialization, only : RGC_initialize_sponges use baroclinic_zone_initialization, only : baroclinic_zone_init_temperature_salinity use benchmark_initialization, only : benchmark_initialize_thickness use benchmark_initialization, only : benchmark_init_temperature_salinity @@ -229,9 +230,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! is just to make sure that all valid parameters are read to enable the ! detection of unused parameters. call get_param(PF, mdl, "INIT_LAYERS_FROM_Z_FILE", from_Z_file, & - "If true, intialize the layer thicknesses, temperatures, \n"//& - "and salnities from a Z-space file on a latitude- \n"//& - "longitude grid.", default=.false., do_not_log=just_read) + "If true, initialize the layer thicknesses, temperatures, "//& + "and salinities from a Z-space file on a latitude-longitude "//& + "grid.", default=.false., do_not_log=just_read) if (from_Z_file) then ! Initialize thickness and T/S from z-coordinate data in a file. @@ -243,7 +244,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & else ! Initialize thickness, h. call get_param(PF, mdl, "THICKNESS_CONFIG", config, & - "A string that determines how the initial layer \n"//& + "A string that determines how the initial layer "//& "thicknesses are specified for a new run: \n"//& " \t file - read interface heights from the file specified \n"//& " \t thickness_file - read thicknesses from the file specified \n"//& @@ -325,7 +326,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! Initialize temperature and salinity (T and S). if ( use_temperature ) then call get_param(PF, mdl, "TS_CONFIG", config, & - "A string that determines how the initial tempertures \n"//& + "A string that determines how the initial tempertures "//& "and salinities are specified for a new run: \n"//& " \t file - read velocities from the file specified \n"//& " \t\t by (TS_FILE). \n"//& @@ -392,7 +393,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! Initialize velocity components, u and v call get_param(PF, mdl, "VELOCITY_CONFIG", config, & - "A string that determines how the initial velocities \n"//& + "A string that determines how the initial velocities "//& "are specified for a new run: \n"//& " \t file - read velocities from the file specified \n"//& " \t\t by (VELOCITY_FILE). \n"//& @@ -431,9 +432,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! Optionally convert the thicknesses from m to kg m-2. This is particularly ! useful in a non-Boussinesq model. call get_param(PF, mdl, "CONVERT_THICKNESS_UNITS", convert, & - "If true, convert the thickness initial conditions from \n"//& - "units of m to kg m-2 or vice versa, depending on whether \n"//& - "BOUSSINESQ is defined. This does not apply if a restart \n"//& + "If true, convert the thickness initial conditions from "//& + "units of m to kg m-2 or vice versa, depending on whether "//& + "BOUSSINESQ is defined. This does not apply if a restart "//& "file is read.", default=.not.GV%Boussinesq, do_not_log=just_read) if (new_sim .and. convert .and. .not.GV%Boussinesq) & @@ -442,12 +443,12 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! Remove the mass that would be displaced by an ice shelf or inverse barometer. call get_param(PF, mdl, "DEPRESS_INITIAL_SURFACE", depress_sfc, & - "If true, depress the initial surface to avoid huge \n"//& + "If true, depress the initial surface to avoid huge "//& "tsunamis when a large surface pressure is applied.", & default=.false., do_not_log=just_read) call get_param(PF, mdl, "TRIM_IC_FOR_P_SURF", trim_ic_for_p_surf, & - "If true, cuts way the top of the column for initial conditions\n"//& - "at the depth where the hydrostatic presure matches the imposed\n"//& + "If true, cuts way the top of the column for initial conditions "//& + "at the depth where the hydrostatic pressure matches the imposed "//& "surface pressure which is read from file.", default=.false., & do_not_log=just_read) if (depress_sfc .and. trim_ic_for_p_surf) call MOM_error(FATAL, "MOM_initialize_state: "//& @@ -461,13 +462,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! iterations here so the initial grid is consistent with the coordinate if (useALE) then call get_param(PF, mdl, "REGRID_ACCELERATE_INIT", regrid_accelerate, & - "If true, runs REGRID_ACCELERATE_ITERATIONS iterations of the regridding\n"//& - "algorithm to push the initial grid to be consistent with the initial\n"//& + "If true, runs REGRID_ACCELERATE_ITERATIONS iterations of the regridding "//& + "algorithm to push the initial grid to be consistent with the initial "//& "condition. Useful only for state-based and iterative coordinates.", & default=.false., do_not_log=just_read) if (regrid_accelerate) then call get_param(PF, mdl, "REGRID_ACCELERATE_ITERATIONS", regrid_iterations, & - "The number of regridding iterations to perform to generate\n"//& + "The number of regridding iterations to perform to generate "//& "an initial grid that is consistent with the initial conditions.", & default=1, do_not_log=just_read) @@ -513,8 +514,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & endif call get_param(PF, mdl, "SPONGE", use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified via SPONGE_CONFIG.", default=.false.) if ( use_sponge ) then call get_param(PF, mdl, "SPONGE_CONFIG", config, & @@ -522,6 +523,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t file - read sponge properties from the file \n"//& " \t\t specified by (SPONGE_FILE).\n"//& " \t ISOMIP - apply ale sponge in the ISOMIP case \n"//& + " \t RGC - apply sponge in the rotating_gravity_current case \n"//& " \t DOME - use a slope and channel configuration for the \n"//& " \t\t DOME sill-overflow test case. \n"//& " \t BFB - Sponge at the southern boundary of the domain\n"//& @@ -533,6 +535,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & sponge_CSp, ALE_sponge_CSp) case ("ISOMIP"); call ISOMIP_initialize_sponges(G, GV, US, tv, PF, useALE, & sponge_CSp, ALE_sponge_CSp) + case("RGC"); call RGC_initialize_sponges(G, GV, tv, u, v, PF, useALE, & + sponge_CSp, ALE_sponge_CSp) case ("USER"); call user_initialize_sponges(G, GV, use_temperature, tv, PF, sponge_CSp, h) case ("BFB"); call BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, PF, & sponge_CSp, h) @@ -554,8 +558,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! This controls user code for setting open boundary data if (associated(OBC)) then call get_param(PF, mdl, "OBC_USER_CONFIG", config, & - "A string that sets how the user code is invoked to set open\n"//& - " boundary data: \n"//& + "A string that sets how the user code is invoked to set open boundary data: \n"//& " DOME - specified inflow on northern boundary\n"//& " dyed_channel - supercritical with dye on the inflow boundary\n"//& " dyed_obcs - circle_obcs with dyes on the open boundaries\n"//& @@ -655,8 +658,8 @@ subroutine initialize_thickness_from_file(h, G, GV, US, param_file, file_has_thi call MOM_read_data(filename, "h", h(:,:,:), G%Domain, scale=GV%m_to_H) else call get_param(param_file, mdl, "ADJUST_THICKNESS", correct_thickness, & - "If true, all mass below the bottom removed if the \n"//& - "topography is shallower than the thickness input file \n"//& + "If true, all mass below the bottom removed if the "//& + "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -854,10 +857,10 @@ subroutine initialize_thickness_list(h, G, GV, US, param_file, just_read_params) just_read = .false. ; if (present(just_read_params)) just_read = just_read_params call get_param(param_file, mdl, "INTERFACE_IC_FILE", eta_file, & - "The file from which horizontal mean initial conditions \n"//& + "The file from which horizontal mean initial conditions "//& "for interface depths can be read.", fail_if_missing=.true.) call get_param(param_file, mdl, "INTERFACE_IC_VAR", eta_var, & - "The variable name for horizontal mean initial conditions \n"//& + "The variable name for horizontal mean initial conditions "//& "for interface depths relative to mean sea level.", & default="eta") @@ -1029,7 +1032,7 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read_params) call log_param(param_file, mdl, "INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_SCALE", scale_factor, & - "A scaling factor to convert SURFACE_HEIGHT_IC_VAR into \n"//& + "A scaling factor to convert SURFACE_HEIGHT_IC_VAR into "//& "units of m", units="variable", default=1.0, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -1108,7 +1111,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) if (.not.just_read) call log_param(PF, mdl, "!INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) call get_param(PF, mdl, "SURFACE_PRESSURE_SCALE", scale_factor, & - "A scaling factor to convert SURFACE_PRESSURE_VAR from\n"//& + "A scaling factor to convert SURFACE_PRESSURE_VAR from "//& "file SURFACE_PRESSURE_FILE into a surface pressure.", & units="file dependent", default=1., do_not_log=just_read) call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & @@ -1371,7 +1374,7 @@ subroutine initialize_velocity_circular(u, v, G, param_file, just_read_params) just_read = .false. ; if (present(just_read_params)) just_read = just_read_params call get_param(param_file, mdl, "CIRCULAR_MAX_U", circular_max_u, & - "The amplitude of zonal flow from which to scale the\n"// & + "The amplitude of zonal flow from which to scale the "// & "circular stream function [m s-1].", & units="m s-1", default=0., do_not_log=just_read) @@ -1487,7 +1490,7 @@ subroutine initialize_temp_salt_from_profile(T, S, G, param_file, just_read_para if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") call get_param(param_file, mdl, "TS_FILE", ts_file, & - "The file with the reference profiles for temperature \n"//& + "The file with the reference profiles for temperature "//& "and salinity.", fail_if_missing=.not.just_read, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -1551,7 +1554,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, param_file, eqn_of_state, P_Ref "A reference salinity used in initialization.", units="PSU", & default=35.0, do_not_log=just_read) call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & - "If true, accept the prescribed temperature and fit the \n"//& + "If true, accept the prescribed temperature and fit the "//& "salinity; otherwise take salinity and fit temperature.", & default=.false., do_not_log=just_read) @@ -1724,27 +1727,27 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C "The name of the file with the state to damp toward.", & default=damping_file) call get_param(param_file, mdl, "SPONGE_PTEMP_VAR", potemp_var, & - "The name of the potential temperature variable in \n"//& + "The name of the potential temperature variable in "//& "SPONGE_STATE_FILE.", default="PTEMP") call get_param(param_file, mdl, "SPONGE_SALT_VAR", salin_var, & - "The name of the salinity variable in \n"//& + "The name of the salinity variable in "//& "SPONGE_STATE_FILE.", default="SALT") call get_param(param_file, mdl, "SPONGE_ETA_VAR", eta_var, & - "The name of the interface height variable in \n"//& + "The name of the interface height variable in "//& "SPONGE_STATE_FILE.", default="ETA") call get_param(param_file, mdl, "SPONGE_IDAMP_VAR", Idamp_var, & - "The name of the inverse damping rate variable in \n"//& + "The name of the inverse damping rate variable in "//& "SPONGE_DAMPING_FILE.", default="IDAMP") call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) call get_param(param_file, mdl, "NEW_SPONGES", new_sponges, & - "Set True if using the newer sponging code which \n"//& + "Set True if using the newer sponging code which "//& "performs on-the-fly regridding in lat-lon-time.",& "of sponge restoring data.", default=.false.) ! if (use_ALE) then ! call get_param(param_file, mdl, "SPONGE_RESTORE_ETA", restore_eta, & -! "If true, then restore the interface positions towards \n"//& +! "If true, then restore the interface positions towards "//& ! "target values (in ALE mode)", default = .false.) ! endif @@ -2024,45 +2027,45 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param call get_param(PF, mdl, "NKBL",nkbl,default=0) call get_param(PF, mdl, "TEMP_SALT_Z_INIT_FILE",filename, & - "The name of the z-space input file used to initialize \n"//& - "temperatures (T) and salinities (S). If T and S are not \n" //& - "in the same file, TEMP_Z_INIT_FILE and SALT_Z_INIT_FILE \n" //& + "The name of the z-space input file used to initialize "//& + "temperatures (T) and salinities (S). If T and S are not "//& + "in the same file, TEMP_Z_INIT_FILE and SALT_Z_INIT_FILE "//& "must be set.",default="temp_salt_z.nc",do_not_log=just_read) call get_param(PF, mdl, "TEMP_Z_INIT_FILE",tfilename, & - "The name of the z-space input file used to initialize \n"//& + "The name of the z-space input file used to initialize "//& "temperatures, only.", default=trim(filename),do_not_log=just_read) call get_param(PF, mdl, "SALT_Z_INIT_FILE",sfilename, & - "The name of the z-space input file used to initialize \n"//& + "The name of the z-space input file used to initialize "//& "temperatures, only.", default=trim(filename),do_not_log=just_read) filename = trim(inputdir)//trim(filename) tfilename = trim(inputdir)//trim(tfilename) sfilename = trim(inputdir)//trim(sfilename) call get_param(PF, mdl, "Z_INIT_FILE_PTEMP_VAR", potemp_var, & - "The name of the potential temperature variable in \n"//& + "The name of the potential temperature variable in "//& "TEMP_Z_INIT_FILE.", default="ptemp",do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_FILE_SALT_VAR", salin_var, & - "The name of the salinity variable in \n"//& + "The name of the salinity variable in "//& "SALT_Z_INIT_FILE.", default="salt",do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_HOMOGENIZE", homogenize, & - "If True, then horizontally homogenize the interpolated \n"//& + "If True, then horizontally homogenize the interpolated "//& "initial conditions.", default=.false., do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_ALE_REMAPPING", useALEremapping, & - "If True, then remap straight to model coordinate from file.",& + "If True, then remap straight to model coordinate from file.", & default=.false., do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remappingScheme, & - "The remapping scheme to use if using Z_INIT_ALE_REMAPPING\n"//& + "The remapping scheme to use if using Z_INIT_ALE_REMAPPING "//& "is True.", default="PPM_IH4", do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_GENERAL", remap_general, & - "If false, only initializes to z* coordinates.\n"//& + "If false, only initializes to z* coordinates. "//& "If true, allows initialization directly to general coordinates.",& default=.false., do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_FULL_COLUMN", remap_full_column, & - "If false, only reconstructs profiles for valid data points.\n"//& - "If true, inserts vanished layers below the valid data.",& + "If false, only reconstructs profiles for valid data points. "//& + "If true, inserts vanished layers below the valid data.", & default=remap_general, do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_OLD_ALG", remap_old_alg, & - "If false, uses the preferred remapping algorithm for initialization.\n"//& - "If true, use an older, less robust algorithm for remapping.",& + "If false, uses the preferred remapping algorithm for initialization. "//& + "If true, use an older, less robust algorithm for remapping.", & default=.true., do_not_log=just_read) call get_param(PF, mdl, "ICE_SHELF", use_ice_shelf, default=.false.) if (use_ice_shelf) then @@ -2077,14 +2080,14 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param endif if (.not.useALEremapping) then call get_param(PF, mdl, "ADJUST_THICKNESS", correct_thickness, & - "If true, all mass below the bottom removed if the \n"//& - "topography is shallower than the thickness input file \n"//& + "If true, all mass below the bottom removed if the "//& + "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) call get_param(PF, mdl, "FIT_TO_TARGET_DENSITY_IC", adjust_temperature, & - "If true, all the interior layers are adjusted to \n"//& - "their target densities using mostly temperature \n"//& - "This approach can be problematic, particularly in the \n"//& + "If true, all the interior layers are adjusted to "//& + "their target densities using mostly temperature "//& + "This approach can be problematic, particularly in the "//& "high latitudes.", default=.true., do_not_log=just_read) endif if (just_read) then diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 27511e1593..08fb487bc5 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -103,14 +103,14 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") call get_param(PF, mdl, "Z_INIT_HOMOGENIZE", homog, & - "If True, then horizontally homogenize the interpolated \n"//& + "If True, then horizontally homogenize the interpolated "//& "initial conditions.", default=.false.) call get_param(PF, mdl, "Z_INIT_ALE_REMAPPING", useALE, & "If True, then remap straight to model coordinate from file.",& default=.true.) call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remapScheme, & - "The remapping scheme to use if using Z_INIT_ALE_REMAPPING\n"//& - "is True.", default="PLM") + "The remapping scheme to use if using Z_INIT_ALE_REMAPPING is True.", & + default="PLM") ! These are model grid properties, but being applied to the data grid for now. ! need to revisit this (mjh) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 1a9bf92c57..27dde7f69d 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -150,7 +150,7 @@ subroutine init_oda(Time, G, GV, CS) call unit_scaling_init(PF, CS%US) call get_param(PF, "MOM", "ASSIM_METHOD", assim_method, & - "String which determines the data assimilation method" // & + "String which determines the data assimilation method "//& "Valid methods are: \'EAKF\',\'OI\', and \'NO_ASSIM\'", default='NO_ASSIM') call get_param(PF, "MOM", "ASSIM_FREQUENCY", CS%assim_frequency, & "data assimilation frequency in hours") @@ -163,14 +163,14 @@ subroutine init_oda(Time, G, GV, CS) "If true, the domain is meridionally reentrant.", & default=.false.) call get_param(PF,"MOM", "TRIPOLAR_N", CS%tripolar_N, & - "Use tripolar connectivity at the northern edge of the \n"//& + "Use tripolar connectivity at the northern edge of the "//& "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & default=.false.) call get_param(PF,"MOM", "NIGLOBAL", CS%ni, & - "The total number of thickness grid points in the \n"//& + "The total number of thickness grid points in the "//& "x-direction in the physical domain.") call get_param(PF,"MOM", "NJGLOBAL", CS%nj, & - "The total number of thickness grid points in the \n"//& + "The total number of thickness grid points in the "//& "y-direction in the physical domain.") call get_param(PF, 'MOM', "INPUTDIR", inputdir) inputdir = slasher(inputdir) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 21ad5a9800..a17bfc6aa9 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -32,10 +32,10 @@ module MOM_MEKE !> Control structure that contains MEKE parameters and diagnostics handles type, public :: MEKE_CS ; private ! Parameters - real :: MEKE_FrCoeff !< Efficiency of conversion of ME into MEKE (non-dim) - real :: MEKE_GMcoeff !< Efficiency of conversion of PE into MEKE (non-dim) - real :: MEKE_GMECoeff !< Efficiency of conversion of MEKE into ME by GME (non-dim) - real :: MEKE_damping !< Local depth-independent MEKE dissipation rate in s-1. + real :: MEKE_FrCoeff !< Efficiency of conversion of ME into MEKE [nondim] + real :: MEKE_GMcoeff !< Efficiency of conversion of PE into MEKE [nondim] + real :: MEKE_GMECoeff !< Efficiency of conversion of MEKE into ME by GME [nondim] + real :: MEKE_damping !< Local depth-independent MEKE dissipation rate [s-1]. real :: MEKE_Cd_scale !< The ratio of the bottom eddy velocity to the column mean !! eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1 !! to account for the surface intensification of MEKE. @@ -51,6 +51,7 @@ module MOM_MEKE logical :: Rd_as_max_scale !< If true the length scale can not exceed the !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. + logical :: use_min_lscale !< Use simple minimum for mixing length scale. real :: cdrag !< The bottom drag coefficient for MEKE [nondim]. real :: MEKE_BGsrc !< Background energy source for MEKE [W kg-1] (= m2 s-3). real :: MEKE_dtScale !< Scale factor to accelerate time-stepping [nondim] @@ -75,6 +76,7 @@ module MOM_MEKE real :: MEKE_advection_factor !< A scaling in front of the advection of MEKE [nondim] real :: MEKE_topographic_beta !< Weight for how much topographic beta is considered !! when computing beta in Rhines scale [nondim] + logical :: kh_flux_enabled !< If true, lateral diffusive MEKE flux is enabled. logical :: initialize !< If True, invokes a steady state solver to calculate MEKE. logical :: debug !< If true, write out checksums of data for debugging @@ -121,18 +123,18 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - mass, & ! The total mass of the water column, in kg m-2. - I_mass, & ! The inverse of mass, in m2 kg-1. - src, & ! The sum of all MEKE sources, in m2 s-3. - MEKE_decay, & ! The MEKE decay timescale, in s-1. - MEKE_GM_src, & ! The MEKE source from thickness mixing, in m2 s-3. - MEKE_mom_src, & ! The MEKE source from momentum, in m2 s-3. - MEKE_GME_snk, & ! The MEKE sink from GME backscatter, in m2 s-3. + mass, & ! The total mass of the water column [kg m-2]. + I_mass, & ! The inverse of mass [m2 kg-1]. + src, & ! The sum of all MEKE sources [m2 s-3]. + MEKE_decay, & ! The MEKE decay timescale [s-1]. + MEKE_GM_src, & ! The MEKE source from thickness mixing [m2 s-3]. + MEKE_mom_src, & ! The MEKE source from momentum [m2 s-3]. + MEKE_GME_snk, & ! The MEKE sink from GME backscatter [m2 s-3]. drag_rate_visc, & - drag_rate, & ! The MEKE spindown timescale due to bottom drag, in s-1. - LmixScale, & ! Square of eddy mixing length, in m2. - barotrFac2, & ! Ratio of EKE_barotropic / EKE (nondim)/ - bottomFac2 ! Ratio of EKE_bottom / EKE (nondim)/ + drag_rate, & ! The MEKE spindown timescale due to bottom drag [s-1]. + LmixScale, & ! Square of eddy mixing length [m2]. + barotrFac2, & ! Ratio of EKE_barotropic / EKE [nondim] + bottomFac2 ! Ratio of EKE_bottom / EKE [nondim] real, dimension(SZIB_(G),SZJ_(G)) :: & MEKE_uflux, & ! The zonal diffusive flux of MEKE [kg m2 s-3]. @@ -272,7 +274,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif ! Calculates bottomFac2, barotrFac2 and LmixScale - call MEKE_lengthScales(CS, MEKE, G, US, SN_u, SN_v, MEKE%MEKE, bottomFac2, barotrFac2, LmixScale) + call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, bottomFac2, barotrFac2, LmixScale) if (CS%debug) then call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI) call hchksum(mass, 'MEKE mass',G%HI,haloshift=1) @@ -425,7 +427,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo endif ! - if (CS%MEKE_KH >= 0.0 .or. CS%KhMEKE_FAC > 0.0 .or. CS%MEKE_advection_factor >0.0) then + if (CS%kh_flux_enabled) then ! Lateral diffusion of MEKE Kh_here = max(0.,CS%MEKE_Kh) !$OMP parallel do default(shared) firstprivate(Kh_here) private(Inv_Kh_max) @@ -636,6 +638,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real :: I_H, KhCoeff, Kh, Ubg2, cd2, drag_rate, ldamping, src real :: EKE, EKEmin, EKEmax, resid, ResMin, ResMax, EKEerr real :: FatH ! Coriolis parameter at h points; to compute topographic beta [s-1] + real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [s-1 m-1] integer :: i, j, is, ie, js, je, n1, n2 real, parameter :: tolerance = 1.e-12 ! Width of EKE bracket [m2 s-2]. logical :: useSecant, debugIteration @@ -655,11 +658,34 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m FatH = 0.25*US%s_to_T*((G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) + & (G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1))) !< Coriolis parameter at h points - !### This expression should be recast to use a single division, but it will change answers. - beta = sqrt( ( US%s_to_T*G%dF_dx(i,j) - CS%MEKE_topographic_beta*FatH/G%bathyT(i,j)* & - (G%bathyT(i+1,j) - G%bathyT(i-1,j))/2./G%dxT(i,j) )**2. & - + ( US%s_to_T*G%dF_dy(i,j) - CS%MEKE_topographic_beta*FatH/G%bathyT(i,j) & - *(G%bathyT(i,j+1) - G%bathyT(i,j-1))/2./G%dyT(i,j) )**2. ) + + ! Since zero-bathymetry cells are masked, this avoids calculations on land + if (CS%MEKE_topographic_beta == 0. .or. G%bathyT(i,j) == 0.) then + beta_topo_x = 0. ; beta_topo_y = 0. + else + !### These expressions should be recast to use a single division, but it will change answers. + !beta_topo_x = CS%MEKE_topographic_beta * FatH & + ! * 0.5 * (G%bathyT(i+1,j) - G%bathyT(i-1,j)) * G%IdxT(i,j) / G%bathyT(i,j) + !beta_topo_y = CS%MEKE_topographic_beta * FatH & + ! * 0.5 * (G%bathyT(i,j+1) - G%bathyT(i,j-1)) * G&IdxT(i,j) / G%bathyT(i,j) + !beta_topo_x = CS%MEKE_topographic_beta * FatH / G%bathyT(i,j) & + ! * (G%bathyT(i+1,j) - G%bathyT(i-1,j)) / 2. / G%dxT(i,j) + !beta_topo_y = CS%MEKE_topographic_beta * FatH / G%bathyT(i,j) & + ! * (G%bathyT(i,j+1) - G%bathyT(i,j-1)) / 2. / G%dyT(i,j) + beta_topo_x = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & + /max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & + + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & + /max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) + beta_topo_y = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & + /max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & + (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdxCu(i,J-1) & + /max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) + endif + + beta = sqrt((US%s_to_T * G%dF_dx(i,j) - beta_topo_x)**2 & + + (US%s_to_T * G%dF_dy(i,j) - beta_topo_y)**2 ) I_H = GV%Rho0 * I_mass(i,j) @@ -752,11 +778,12 @@ end subroutine MEKE_equilibrium !> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ !! functions that are ratios of either bottom or barotropic eddy energy to the !! column eddy energy, respectively. See \ref section_MEKE_equations. -subroutine MEKE_lengthScales(CS, MEKE, G, US, SN_u, SN_v, & +subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, & EKE, bottomFac2, barotrFac2, LmixScale) type(MEKE_CS), pointer :: CS !< MEKE control structure. type(MEKE_type), pointer :: MEKE !< MEKE data. type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [s-1]. @@ -768,6 +795,7 @@ subroutine MEKE_lengthScales(CS, MEKE, G, US, SN_u, SN_v, & real, dimension(SZI_(G),SZJ_(G)) :: Lrhines, Leady real :: beta, SN real :: FatH ! Coriolis parameter at h points [s-1] + real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [s-1 m-1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -776,17 +804,45 @@ subroutine MEKE_lengthScales(CS, MEKE, G, US, SN_u, SN_v, & do j=js,je ; do i=is,ie if (.not.CS%use_old_lscale) then if (CS%aEady > 0.) then - SN = 0.25*( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)) ) + SN = 0.25*( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)) ) else SN = 0. endif - FatH = 0.25*US%s_to_T* ( ( G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1) ) + & - ( G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1) ) ) ! Coriolis parameter at h points - !### This expression should be recast to use a single division, but it will change answers. - beta = sqrt( ( US%s_to_T*G%dF_dx(i,j) - CS%MEKE_topographic_beta*FatH/G%bathyT(i,j) & - *(G%bathyT(i+1,j) - G%bathyT(i-1,j)) /2./G%dxT(i,j) )**2. & - + ( US%s_to_T*G%dF_dy(i,j) - CS%MEKE_topographic_beta*FatH/G%bathyT(i,j) & - *(G%bathyT(i,j+1) - G%bathyT(i,j-1))/2./G%dyT(i,j) )**2. ) + FatH = 0.25*US%s_to_T* ( ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1) ) + & + ( G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1) ) ) ! Coriolis parameter at h points + + ! If bathyT is zero, then a division by zero FPE will be raised. In this + ! case, we apply Adcroft's rule of reciprocals and set the term to zero. + ! Since zero-bathymetry cells are masked, this should not affect values. + if (CS%MEKE_topographic_beta == 0. .or. G%bathyT(i,j) == 0.0) then + beta_topo_x = 0. ; beta_topo_y = 0. + else + !### These expressions should be recast to use a single division, but it will change answers. + !beta_topo_x = CS%MEKE_topographic_beta * FatH & + ! * 0.5 * (G%bathyT(i+1,j) - G%bathyT(i-1,j)) * G%IdxT(i,j) / G%bathyT(i,j) + !beta_topo_y = CS%MEKE_topographic_beta * FatH & + ! * 0.5 * (G%bathyT(i,j+1) - G%bathyT(i,j-1)) * G&IdxT(i,j) / G%bathyT(i,j) + !beta_topo_x = CS%MEKE_topographic_beta * FatH / G%bathyT(i,j) & + ! * (G%bathyT(i+1,j) - G%bathyT(i-1,j)) / 2. / G%dxT(i,j) + !beta_topo_y = CS%MEKE_topographic_beta * FatH / G%bathyT(i,j) & + ! * (G%bathyT(i,j+1) - G%bathyT(i,j-1)) / 2. / G%dyT(i,j) + beta_topo_x = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & + /max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & + + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & + /max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) + beta_topo_y = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & + /max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & + (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdxCu(i,J-1) & + /max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) + endif + + beta = sqrt((US%s_to_T * G%dF_dx(i,j) - beta_topo_x)**2 & + + (US%s_to_T * G%dF_dy(i,j) - beta_topo_y)**2 ) + + else + beta = 0. endif ! Returns bottomFac2, barotrFac2 and LmixScale call MEKE_lengthScales_0d(CS, G%areaT(i,j), beta, G%bathyT(i,j), & @@ -849,14 +905,24 @@ subroutine MEKE_lengthScales_0d(CS, area, beta, depth, Rd_dx, SN, EKE, Z_to_L, & else Leady = 0. endif - LmixScale = 0. - if (CS%aDeform*Ldeform > 0.) LmixScale = LmixScale + 1./(CS%aDeform*Ldeform) - if (CS%aFrict *Lfrict > 0.) LmixScale = LmixScale + 1./(CS%aFrict *Lfrict) - if (CS%aRhines*Lrhines > 0.) LmixScale = LmixScale + 1./(CS%aRhines*Lrhines) - if (CS%aEady *Leady > 0.) LmixScale = LmixScale + 1./(CS%aEady *Leady) - if (CS%aGrid *Lgrid > 0.) LmixScale = LmixScale + 1./(CS%aGrid *Lgrid) - if (CS%Lfixed > 0.) LmixScale = LmixScale + 1./CS%Lfixed - if (LmixScale > 0.) LmixScale = 1. / LmixScale + if (CS%use_min_lscale) then + LmixScale = 1.e7 + if (CS%aDeform*Ldeform > 0.) LmixScale = min(LmixScale,CS%aDeform*Ldeform) + if (CS%aFrict *Lfrict > 0.) LmixScale = min(LmixScale,CS%aFrict *Lfrict) + if (CS%aRhines*Lrhines > 0.) LmixScale = min(LmixScale,CS%aRhines*Lrhines) + if (CS%aEady *Leady > 0.) LmixScale = min(LmixScale,CS%aEady *Leady) + if (CS%aGrid *Lgrid > 0.) LmixScale = min(LmixScale,CS%aGrid *Lgrid) + if (CS%Lfixed > 0.) LmixScale = min(LmixScale,CS%Lfixed) + else + LmixScale = 0. + if (CS%aDeform*Ldeform > 0.) LmixScale = LmixScale + 1./(CS%aDeform*Ldeform) + if (CS%aFrict *Lfrict > 0.) LmixScale = LmixScale + 1./(CS%aFrict *Lfrict) + if (CS%aRhines*Lrhines > 0.) LmixScale = LmixScale + 1./(CS%aRhines*Lrhines) + if (CS%aEady *Leady > 0.) LmixScale = LmixScale + 1./(CS%aEady *Leady) + if (CS%aGrid *Lgrid > 0.) LmixScale = LmixScale + 1./(CS%aGrid *Lgrid) + if (CS%Lfixed > 0.) LmixScale = LmixScale + 1./CS%Lfixed + if (LmixScale > 0.) LmixScale = 1. / LmixScale + endif endif end subroutine MEKE_lengthScales_0d @@ -884,7 +950,7 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) ! Determine whether this module will be used call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_MEKE", MEKE_init, & - "If true, turns on the MEKE scheme which calculates\n"// & + "If true, turns on the MEKE scheme which calculates "// & "a sub-grid mesoscale eddy kinetic energy budget.", & default=.false.) if (.not. MEKE_init) return @@ -905,72 +971,72 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "MEKE_DAMPING", CS%MEKE_damping, & - "The local depth-indepented MEKE dissipation rate.", & + "The local depth-independent MEKE dissipation rate.", & units="s-1", default=0.0) call get_param(param_file, mdl, "MEKE_CD_SCALE", CS%MEKE_Cd_scale, & - "The ratio of the bottom eddy velocity to the column mean\n"//& - "eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1\n"//& + "The ratio of the bottom eddy velocity to the column mean "//& + "eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1 "//& "to account for the surface intensification of MEKE.", & units="nondim", default=0.) call get_param(param_file, mdl, "MEKE_CB", CS%MEKE_Cb, & - "A coefficient in the expression for the ratio of bottom projected\n"//& + "A coefficient in the expression for the ratio of bottom projected "//& "eddy energy and mean column energy (see Jansen et al. 2015).",& units="nondim", default=25.) call get_param(param_file, mdl, "MEKE_MIN_GAMMA2", CS%MEKE_min_gamma, & "The minimum allowed value of gamma_b^2.",& units="nondim", default=0.0001) call get_param(param_file, mdl, "MEKE_CT", CS%MEKE_Ct, & - "A coefficient in the expression for the ratio of barotropic\n"//& + "A coefficient in the expression for the ratio of barotropic "//& "eddy energy and mean column energy (see Jansen et al. 2015).",& units="nondim", default=50.) call get_param(param_file, mdl, "MEKE_GMCOEFF", CS%MEKE_GMcoeff, & - "The efficiency of the conversion of potential energy \n"//& - "into MEKE by the thickness mixing parameterization. \n"//& - "If MEKE_GMCOEFF is negative, this conversion is not \n"//& + "The efficiency of the conversion of potential energy "//& + "into MEKE by the thickness mixing parameterization. "//& + "If MEKE_GMCOEFF is negative, this conversion is not "//& "used or calculated.", units="nondim", default=-1.0) call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & - "If MEKE_GEOMETRIC is true, uses the GM coefficient formulation \n"//& + "If MEKE_GEOMETRIC is true, uses the GM coefficient formulation "//& "from the GEOMETRIC framework (Marshall et al., 2012).", default=.false.) call get_param(param_file, mdl, "MEKE_FRCOEFF", CS%MEKE_FrCoeff, & - "The efficiency of the conversion of mean energy into \n"//& - "MEKE. If MEKE_FRCOEFF is negative, this conversion \n"//& + "The efficiency of the conversion of mean energy into "//& + "MEKE. If MEKE_FRCOEFF is negative, this conversion "//& "is not used or calculated.", units="nondim", default=-1.0) call get_param(param_file, mdl, "MEKE_GMECOEFF", CS%MEKE_GMECoeff, & - "The efficiency of the conversion of MEKE into mean energy \n"//& - "by GME. If MEKE_GMECOEFF is negative, this conversion \n"//& + "The efficiency of the conversion of MEKE into mean energy "//& + "by GME. If MEKE_GMECOEFF is negative, this conversion "//& "is not used or calculated.", units="nondim", default=-1.0) call get_param(param_file, mdl, "MEKE_BGSRC", CS%MEKE_BGsrc, & "A background energy source for MEKE.", units="W kg-1", & default=0.0) call get_param(param_file, mdl, "MEKE_KH", CS%MEKE_Kh, & - "A background lateral diffusivity of MEKE.\n"//& + "A background lateral diffusivity of MEKE. "//& "Use a negative value to not apply lateral diffusion to MEKE.", & units="m2 s-1", default=-1.0) call get_param(param_file, mdl, "MEKE_K4", CS%MEKE_K4, & - "A lateral bi-harmonic diffusivity of MEKE.\n"//& + "A lateral bi-harmonic diffusivity of MEKE. "//& "Use a negative value to not apply bi-harmonic diffusion to MEKE.", & units="m4 s-1", default=-1.0) call get_param(param_file, mdl, "MEKE_DTSCALE", CS%MEKE_dtScale, & "A scaling factor to accelerate the time evolution of MEKE.", & units="nondim", default=1.0) call get_param(param_file, mdl, "MEKE_KHCOEFF", CS%MEKE_KhCoeff, & - "A scaling factor in the expression for eddy diffusivity\n"//& - "which is otherwise proportional to the MEKE velocity-\n"//& - "scale times an eddy mixing-length. This factor\n"//& - "must be >0 for MEKE to contribute to the thickness/\n"//& + "A scaling factor in the expression for eddy diffusivity "//& + "which is otherwise proportional to the MEKE velocity- "//& + "scale times an eddy mixing-length. This factor "//& + "must be >0 for MEKE to contribute to the thickness/ "//& "and tracer diffusivity in the rest of the model.", & units="nondim", default=1.0) call get_param(param_file, mdl, "MEKE_USCALE", CS%MEKE_Uscale, & - "The background velocity that is combined with MEKE to \n"//& + "The background velocity that is combined with MEKE to "//& "calculate the bottom drag.", units="m s-1", default=0.0) call get_param(param_file, mdl, "MEKE_JANSEN15_DRAG", CS%Jansen15_drag, & - "If true, use the bottom drag formulation from Jansen et al. (2015) \n"//& + "If true, use the bottom drag formulation from Jansen et al. (2015) "//& "to calculate the drag acting on MEKE.", default=.false.) call get_param(param_file, mdl, "MEKE_GM_SRC_ALT", CS%GM_src_alt, & - "If true, use the GM energy conversion form S^2*N^2*kappa rather \n"//& + "If true, use the GM energy conversion form S^2*N^2*kappa rather "//& "than the streamfunction for the MEKE GM source term.", default=.false.) call get_param(param_file, mdl, "MEKE_VISC_DRAG", CS%visc_drag, & - "If true, use the vertvisc_type to calculate the bottom \n"//& + "If true, use the vertvisc_type to calculate the bottom "//& "drag acting on MEKE.", default=.true.) call get_param(param_file, mdl, "MEKE_KHTH_FAC", MEKE%KhTh_fac, & "A factor that maps MEKE%Kh to KhTh.", units="nondim", & @@ -982,73 +1048,77 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) "A factor that maps MEKE%Kh to Kh for MEKE itself.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_OLD_LSCALE", CS%use_old_lscale, & - "If true, use the old formula for length scale which is\n"//& + "If true, use the old formula for length scale which is "//& "a function of grid spacing and deformation radius.", & default=.false.) + call get_param(param_file, mdl, "MEKE_MIN_LSCALE", CS%use_min_lscale, & + "If true, use a strict minimum of provided length scales "//& + "rather than harmonic mean.", & + default=.false.) call get_param(param_file, mdl, "MEKE_RD_MAX_SCALE", CS%Rd_as_max_scale, & - "If true, the length scale used by MEKE is the minimum of\n"//& - "the deformation radius or grid-spacing. Only used if\n"//& + "If true, the length scale used by MEKE is the minimum of "//& + "the deformation radius or grid-spacing. Only used if "//& "MEKE_OLD_LSCALE=True", units="nondim", default=.false.) call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF_KU", CS%viscosity_coeff_Ku, & - "If non-zero, is the scaling coefficient in the expression for\n"//& - "viscosity used to parameterize harmonic lateral momentum mixing by\n"//& - "unresolved eddies represented by MEKE. Can be negative to\n"//& + "If non-zero, is the scaling coefficient in the expression for"//& + "viscosity used to parameterize harmonic lateral momentum mixing by"//& + "unresolved eddies represented by MEKE. Can be negative to"//& "represent backscatter from the unresolved eddies.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF_AU", CS%viscosity_coeff_Au, & - "If non-zero, is the scaling coefficient in the expression for\n"//& - "viscosity used to parameterize biharmonic lateral momentum mixing by\n"//& - "unresolved eddies represented by MEKE. Can be negative to\n"//& + "If non-zero, is the scaling coefficient in the expression for"//& + "viscosity used to parameterize biharmonic lateral momentum mixing by"//& + "unresolved eddies represented by MEKE. Can be negative to"//& "represent backscatter from the unresolved eddies.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_FIXED_MIXING_LENGTH", CS%Lfixed, & - "If positive, is a fixed length contribution to the expression\n"//& - "for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a fixed length contribution to the expression "//& + "for mixing length used in MEKE-derived diffusivity.", & units="m", default=0.0) call get_param(param_file, mdl, "MEKE_ALPHA_DEFORM", CS%aDeform, & - "If positive, is a coefficient weighting the deformation scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the deformation scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_ALPHA_RHINES", CS%aRhines, & - "If positive, is a coefficient weighting the Rhines scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the Rhines scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.05) call get_param(param_file, mdl, "MEKE_ALPHA_EADY", CS%aEady, & - "If positive, is a coefficient weighting the Eady length scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the Eady length scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.05) call get_param(param_file, mdl, "MEKE_ALPHA_FRICT", CS%aFrict, & - "If positive, is a coefficient weighting the frictional arrest scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the frictional arrest scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_ALPHA_GRID", CS%aGrid, & - "If positive, is a coefficient weighting the grid-spacing as a scale\n"//& - "in the expression for mixing length used in MEKE-derived diffusiviity.", & + "If positive, is a coefficient weighting the grid-spacing as a scale "//& + "in the expression for mixing length used in MEKE-derived diffusivity.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_COLD_START", coldStart, & - "If true, initialize EKE to zero. Otherwise a local equilibrium solution\n"//& + "If true, initialize EKE to zero. Otherwise a local equilibrium solution "//& "is used as an initial condition for EKE.", default=.false.) call get_param(param_file, mdl, "MEKE_BACKSCAT_RO_C", MEKE%backscatter_Ro_c, & - "The coefficient in the Rossby number function for scaling the biharmonic\n"//& + "The coefficient in the Rossby number function for scaling the biharmonic "//& "frictional energy source. Setting to non-zero enables the Rossby number function.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_BACKSCAT_RO_POW", MEKE%backscatter_Ro_pow, & - "The power in the Rossby number function for scaling the biharmomnic\n"//& + "The power in the Rossby number function for scaling the biharmonic "//& "frictional energy source.", units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_ADVECTION_FACTOR", CS%MEKE_advection_factor, & - "A scale factor in front of advection of eddy energy. Zero turns advection off.\n"//& - "Using unity would be normal but other values could accomodate a mismatch\n"//& + "A scale factor in front of advection of eddy energy. Zero turns advection off. "//& + "Using unity would be normal but other values could accommodate a mismatch "//& "between the advecting barotropic flow and the vertical structure of MEKE.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_TOPOGRAPHIC_BETA", CS%MEKE_topographic_beta, & - "A scale factor to determine how much topographic beta is weighed in\n" //& - "computing beta in the expression of Rhines scale. Use 1 if full\n"//& + "A scale factor to determine how much topographic beta is weighed in " //& + "computing beta in the expression of Rhines scale. Use 1 if full "//& "topographic beta effect is considered; use 0 if it's completely ignored.", & units="nondim", default=0.0) ! Nonlocal module parameters call get_param(param_file, mdl, "CDRAG", CS%cdrag, & - "CDRAG is the drag coefficient relating the magnitude of \n"//& + "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", units="nondim", & default=0.003) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) @@ -1067,6 +1137,13 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) allocate(CS%del2MEKE(isd:ied,jsd:jed)) ; CS%del2MEKE(:,:) = 0.0 endif + ! Identify if any lateral diffusive processes are active + CS%kh_flux_enabled = .false. + if (CS%MEKE_KH >= 0.0 & + .or. CS%KhMEKE_FAC > 0.0 & + .or. CS%MEKE_advection_factor >0.0) & + CS%kh_flux_enabled = .true. + ! In the case of a restart, these fields need a halo update if (associated(MEKE%MEKE)) then call create_group_pass(CS%pass_MEKE, MEKE%MEKE, G%Domain) @@ -1120,10 +1197,6 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) 'MEKE energy source', 'm2 s-3') CS%id_decay = register_diag_field('ocean_model', 'MEKE_decay', diag%axesT1, Time, & 'MEKE decay rate', 's-1') - CS%id_KhMEKE_u = register_diag_field('ocean_model', 'KHMEKE_u', diag%axesCu1, Time, & - 'Zonal diffusivity of MEKE', 'm2 s-1') - CS%id_KhMEKE_v = register_diag_field('ocean_model', 'KHMEKE_v', diag%axesCv1, Time, & - 'Meridional diffusivity of MEKE', 'm2 s-1') CS%id_GM_src = register_diag_field('ocean_model', 'MEKE_GM_src', diag%axesT1, Time, & 'MEKE energy available from thickness mixing', 'W m-2') if (.not. associated(MEKE%GM_src)) CS%id_GM_src = -1 @@ -1144,6 +1217,13 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) CS%id_gamma_t = register_diag_field('ocean_model', 'MEKE_gamma_t', diag%axesT1, Time, & 'Ratio of barotropic eddy velocity to column-mean eddy velocity', 'nondim') + if (CS%kh_flux_enabled) then + CS%id_KhMEKE_u = register_diag_field('ocean_model', 'KHMEKE_u', diag%axesCu1, Time, & + 'Zonal diffusivity of MEKE', 'm2 s-1') + CS%id_KhMEKE_v = register_diag_field('ocean_model', 'KHMEKE_v', diag%axesCv1, Time, & + 'Meridional diffusivity of MEKE', 'm2 s-1') + endif + CS%id_clock_pass = cpu_clock_id('(Ocean continuity halo updates)', grain=CLOCK_ROUTINE) ! Detect whether this instant of MEKE_init() is at the beginning of a run @@ -1306,7 +1386,7 @@ end subroutine MEKE_end !! \f$ \gamma_\eta \in [0,1] \f$. !! !! The "frictional" source term -!! \f[ \dot{E}_{v} = \left< u \cdot \tau_h \right> \f] +!! \f[ \dot{E}_{v} = \left< \partial_i u_j \tau_{ij} \right> \f] !! equals the mean kinetic energy removed by lateral viscous fluxes, and !! is excluded/included in the MEKE budget by the efficiency parameter !! \f$ \gamma_v \in [0,1] \f$. diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index 0f4c58b68c..95106f1fdb 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -8,18 +8,18 @@ module MOM_MEKE_types type, public :: MEKE_type ! Variables real, dimension(:,:), pointer :: & - MEKE => NULL(), & !< Vertically averaged eddy kinetic energy, in m2 s-2. - GM_src => NULL(), & !< MEKE source due to thickness mixing (GM), in W m-2. - mom_src => NULL(),& !< MEKE source from lateral friction in the momentum equations, in W m-2. - GME_snk => NULL(),& !< MEKE sink from GME backscatter in the momentum equations, in W m-2. - Kh => NULL(), & !< The MEKE-derived lateral mixing coefficient in m2 s-1. - Kh_diff => NULL(), & !< Uses the non-MEKE-derived thickness diffusion coefficient to diffuse MEKE, in m2 s-1. - Rd_dx_h => NULL() !< The deformation radius compared with the grid spacing, nondim. + MEKE => NULL(), & !< Vertically averaged eddy kinetic energy [m2 s-2]. + GM_src => NULL(), & !< MEKE source due to thickness mixing (GM) [W m-2]. + mom_src => NULL(),& !< MEKE source from lateral friction in the momentum equations [W m-2]. + GME_snk => NULL(),& !< MEKE sink from GME backscatter in the momentum equations [W m-2]. + Kh => NULL(), & !< The MEKE-derived lateral mixing coefficient [m2 s-1]. + Kh_diff => NULL(), & !< Uses the non-MEKE-derived thickness diffusion coefficient to diffuse MEKE [m2 s-1]. + Rd_dx_h => NULL() !< The deformation radius compared with the grid spacing [nondim]. !! Rd_dx_h is copied from VarMix_CS. real, dimension(:,:), pointer :: Ku => NULL() !< The MEKE-derived lateral viscosity coefficient [m2 s-1]. !! This viscosity can be negative when representing backscatter !! from unresolved eddies (see Jansen and Held, 2014). - real, dimension(:,:), pointer :: Au => NULL() !< The MEKE-derived lateral biharmonic viscosity coefficient in m4 s-1. + real, dimension(:,:), pointer :: Au => NULL() !< The MEKE-derived lateral biharmonic viscosity coefficient [m4 s-1]. ! Parameters real :: KhTh_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTh [nondim] real :: KhTr_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTr [nondim]. diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 977d9b9228..efba8e8e8d 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -76,6 +76,8 @@ module MOM_hor_visc real :: Kh_aniso !< The anisotropic viscosity [m2 s-1]. logical :: dynamic_aniso !< If true, the anisotropic viscosity is recomputed as a function !! of state. This is set depending on ANISOTROPIC_MODE. + logical :: res_scale_MEKE !< If true, the viscosity contribution from MEKE is scaled by + !! the resolution function. logical :: use_GME !< If true, use GME backscatter scheme. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx @@ -146,18 +148,18 @@ module MOM_hor_visc ! The following variables are precalculated time-invariant combinations of ! parameters and metric terms. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - Laplac2_const_xx, & !< Laplacian metric-dependent constants (nondim) - Biharm5_const_xx, & !< Biharmonic metric-dependent constants (nondim) - Laplac3_const_xx, & !< Laplacian metric-dependent constants (nondim) - Biharm_const_xx, & !< Biharmonic metric-dependent constants (nondim) - Biharm_const2_xx !< Biharmonic metric-dependent constants (nondim) + Laplac2_const_xx, & !< Laplacian metric-dependent constants [nondim] + Biharm5_const_xx, & !< Biharmonic metric-dependent constants [nondim] + Laplac3_const_xx, & !< Laplacian metric-dependent constants [nondim] + Biharm_const_xx, & !< Biharmonic metric-dependent constants [nondim] + Biharm_const2_xx !< Biharmonic metric-dependent constants [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - Laplac2_const_xy, & !< Laplacian metric-dependent constants (nondim) - Biharm5_const_xy, & !< Biharmonic metric-dependent constants (nondim) - Laplac3_const_xy, & !< Laplacian metric-dependent constants (nondim) - Biharm_const_xy, & !< Biharmonic metric-dependent constants (nondim) - Biharm_const2_xy !< Biharmonic metric-dependent constants (nondim) + Laplac2_const_xy, & !< Laplacian metric-dependent constants [nondim] + Biharm5_const_xy, & !< Biharmonic metric-dependent constants [nondim] + Laplac3_const_xy, & !< Laplacian metric-dependent constants [nondim] + Biharm_const_xy, & !< Biharmonic metric-dependent constants [nondim] + Biharm_const2_xy !< Biharmonic metric-dependent constants [nondim] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics @@ -199,8 +201,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(out) :: diffu !< Zonal acceleration due to convergence of !! along-coordinate stress tensor [m s-2] @@ -211,8 +212,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! related to Mesoscale Eddy Kinetic Energy. type(VarMix_CS), pointer :: VarMix !< Pointer to a structure with fields that !! specify the spatially variable viscosities - type(hor_visc_CS), pointer :: CS !< Control structure returned by a previous type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(hor_visc_CS), pointer :: CS !< Control structure returned by a previous !! call to hor_visc_init. type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type type(barotropic_CS), optional, pointer :: BT !< Pointer to a structure containing @@ -220,119 +221,120 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & - u0, & ! Laplacian of u (m-1 s-1) - h_u, & ! Thickness interpolated to u points, in H. - vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) (m-1 s-1) - div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) (m-1 s-1) - ubtav ! zonal barotropic vel. ave. over baroclinic time-step (m s-1) + u0, & ! Laplacian of u [m-1 s-1] + h_u, & ! Thickness interpolated to u points [H ~> m or kg m-2]. + vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [m-1 s-1] + div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [m-1 s-1] + ubtav ! zonal barotropic vel. ave. over baroclinic time-step [m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & - v0, & ! Laplacian of v (m-1 s-1) - h_v, & ! Thickness interpolated to v points, in H. - vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) (m-1 s-1) - div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) (m-1 s-1) - vbtav ! meridional barotropic vel. ave. over baroclinic time-step (m s-1) + v0, & ! Laplacian of v [m-1 s-1] + h_v, & ! Thickness interpolated to v points [H ~> m or kg m-2]. + vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [m-1 s-1] + div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [m-1 s-1] + vbtav ! meridional barotropic vel. ave. over baroclinic time-step [m s-1] real, dimension(SZI_(G),SZJ_(G)) :: & - dudx_bt, dvdy_bt, & ! components in the barotropic horizontal tension (s-1) - div_xx, & ! Estimate of horizontal divergence at h-points (s-1) - sh_xx, & ! horizontal tension (du/dx - dv/dy) (1/sec) including metric terms - sh_xx_bt, & ! barotropic horizontal tension (du/dx - dv/dy) (1/sec) including metric terms - str_xx,& ! str_xx is the diagonal term in the stress tensor (H m2 s-2) - str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME (H m2 s-2) - bhstr_xx,& ! A copy of str_xx that only contains the biharmonic contribution (H m2 s-2) - FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction (W/m2) - Leith_Kh_h, & ! Leith Laplacian viscosity at h-points (m2 s-1) - Leith_Ah_h, & ! Leith bi-harmonic viscosity at h-points (m4 s-1) - beta_h, & ! Gradient of planetary vorticity at h-points (m-1 s-1) - grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points (m-1 s-1) - grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points (m-1 s-1) - grad_div_mag_h, & ! Magnitude of divergence gradient at h-points (m-1 s-1) - dudx, dvdy, & ! components in the horizontal tension (s-1) - grad_vel_mag_h, & ! Magnitude of the velocity gradient tensor squared at h-points (s-2) - grad_vel_mag_bt_h, & ! Magnitude of the barotropic velocity gradient tensor squared at h-points (s-2) - grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared (m-2 s-2) - max_diss_rate_bt, & ! maximum possible energy dissipated by barotropic lateral friction (m2 s-3) + dudx_bt, dvdy_bt, & ! components in the barotropic horizontal tension [s-1] + div_xx, & ! Estimate of horizontal divergence at h-points [s-1] + sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [s-1] + sh_xx_bt, & ! barotropic horizontal tension (du/dx - dv/dy) including metric terms [s-1] + str_xx,& ! str_xx is the diagonal term in the stress tensor [H m2 s-2 ~> m3 s-2 or kg s-2] + str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [H m2 s-2] + bhstr_xx,& ! A copy of str_xx that only contains the biharmonic contribution [H m2 s-2 ~> m3 s-2 or kg s-2] + FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [W m-2] + Leith_Kh_h, & ! Leith Laplacian viscosity at h-points [m2 s-1] + Leith_Ah_h, & ! Leith bi-harmonic viscosity at h-points [m4 s-1] + beta_h, & ! Gradient of planetary vorticity at h-points [m-1 s-1] + grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [m-1 s-1] + grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [m-1 s-1] + grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [m-1 s-1] + dudx, dvdy, & ! components in the horizontal tension [s-1] + grad_vel_mag_h, & ! Magnitude of the velocity gradient tensor squared at h-points [s-2] + grad_vel_mag_bt_h, & ! Magnitude of the barotropic velocity gradient tensor squared at h-points [s-2] + grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [m-2 s-2] + max_diss_rate_bt, & ! maximum possible energy dissipated by barotropic lateral friction [m2 s-3] boundary_mask ! A mask that zeroes out cells with at least one land edge real, dimension(SZIB_(G),SZJB_(G)) :: & - dvdx, dudy, & ! components in the shearing strain (s-1) - dvdx_bt, dudy_bt, & ! components in the barotropic shearing strain (s-1) - sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) (1/sec) including metric terms - sh_xy_bt, & ! barotropic horizontal shearing strain (du/dy + dv/dx) (1/sec) inc. metric terms - str_xy, & ! str_xy is the cross term in the stress tensor (H m2 s-2) - str_xy_GME, & ! smoothed cross term in the stress tensor from GME (H m2 s-2) - bhstr_xy, & ! A copy of str_xy that only contains the biharmonic contribution (H m2 s-2) - vort_xy, & ! Vertical vorticity (dv/dx - du/dy) (s-1) - Leith_Kh_q, & ! Leith Laplacian viscosity at q-points (m2 s-1) - Leith_Ah_q, & ! Leith bi-harmonic viscosity at q-points (m4 s-1) - beta_q, & ! Gradient of planetary vorticity at q-points (m-1 s-1) - grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points (m-1 s-1) - grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points (m-1 s-1) - grad_div_mag_q, & ! Magnitude of divergence gradient at q-points (m-1 s-1) - grad_vel_mag_q, & ! Magnitude of the velocity gradient tensor squared at q-points (s-2) - hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses, in H; This form guarantees that hq/hu < 4. - grad_vel_mag_bt_q ! Magnitude of the barotropic velocity gradient tensor squared at q-points (s-2) + dvdx, dudy, & ! components in the shearing strain [s-1] + dvdx_bt, dudy_bt, & ! components in the barotropic shearing strain [s-1] + sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [s-1] + sh_xy_bt, & ! barotropic horizontal shearing strain (du/dy + dv/dx) inc. metric terms [s-1] + str_xy, & ! str_xy is the cross term in the stress tensor [H m2 s-2 ~> m3 s-2 or kg s-2] + str_xy_GME, & ! smoothed cross term in the stress tensor from GME [H m2 s-2] + bhstr_xy, & ! A copy of str_xy that only contains the biharmonic contribution [H m2 s-2 ~> m3 s-2 or kg s-2] + vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [s-1] + Leith_Kh_q, & ! Leith Laplacian viscosity at q-points [m2 s-1] + Leith_Ah_q, & ! Leith bi-harmonic viscosity at q-points [m4 s-1] + beta_q, & ! Gradient of planetary vorticity at q-points [m-1 s-1] + grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [m-1 s-1] + grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [m-1 s-1] + grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [m-1 s-1] + grad_vel_mag_q, & ! Magnitude of the velocity gradient tensor squared at q-points [s-2] + hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] + ! This form guarantees that hq/hu < 4. + grad_vel_mag_bt_q ! Magnitude of the barotropic velocity gradient tensor squared at q-points [s-2] real, dimension(SZIB_(G),SZJB_(G),SZK_(G)) :: & - Ah_q, & ! biharmonic viscosity at corner points (m4/s) - Kh_q, & ! Laplacian viscosity at corner points (m2/s) - vort_xy_q, & ! vertical vorticity at corner points (s-1) - GME_coeff_q !< GME coeff. at q-points (m2 s-1) + Ah_q, & ! biharmonic viscosity at corner points [m4 s-1] + Kh_q, & ! Laplacian viscosity at corner points [m2 s-1] + vort_xy_q, & ! vertical vorticity at corner points [s-1] + GME_coeff_q !< GME coeff. at q-points [m2 s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1) :: & - KH_u_GME !< interface height diffusivities in u-columns (m2 s-1) + KH_u_GME !< interface height diffusivities in u-columns [m2 s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1) :: & - KH_v_GME !< interface height diffusivities in v-columns (m2 s-1) + KH_v_GME !< interface height diffusivities in v-columns [m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - Ah_h, & ! biharmonic viscosity at thickness points (m4/s) - Kh_h, & ! Laplacian viscosity at thickness points (m2/s) - diss_rate, & ! MKE dissipated by parameterized shear production (m2 s-3) - max_diss_rate, & ! maximum possible energy dissipated by lateral friction (m2 s-3) + Ah_h, & ! biharmonic viscosity at thickness points [m4 s-1] + Kh_h, & ! Laplacian viscosity at thickness points [m2 s-1] + diss_rate, & ! MKE dissipated by parameterized shear production [m2 s-3] + max_diss_rate, & ! maximum possible energy dissipated by lateral friction [m2 s-3] target_diss_rate_GME, & ! the maximum theoretical dissipation plus the amount spuriously dissipated - ! by friction (m2 s-3) - FrictWork, & ! work done by MKE dissipation mechanisms (W/m2) - FrictWork_diss, & ! negative definite work done by MKE dissipation mechanisms (W/m2) - FrictWorkMax, & ! maximum possible work done by MKE dissipation mechanisms (W/m2) - FrictWork_GME, & ! work done by GME (W/m2) - div_xx_h ! horizontal divergence (s-1) + ! by friction [m2 s-3] + FrictWork, & ! work done by MKE dissipation mechanisms [W m-2] + FrictWork_diss, & ! negative definite work done by MKE dissipation mechanisms [W m-2] + FrictWorkMax, & ! maximum possible work done by MKE dissipation mechanisms [W m-2] + FrictWork_GME, & ! work done by GME [W m-2] + div_xx_h ! horizontal divergence [s-1] !real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - KH_t_GME, & !< interface height diffusivities in t-columns (m2 s-1) - GME_coeff_h !< GME coeff. at h-points (m2 s-1) - real :: Ah ! biharmonic viscosity (m4/s) - real :: Kh ! Laplacian viscosity (m2/s) - real :: AhSm ! Smagorinsky biharmonic viscosity (m4/s) - real :: KhSm ! Smagorinsky Laplacian viscosity (m2/s) - real :: AhLth ! 2D Leith biharmonic viscosity (m4/s) - real :: KhLth ! 2D Leith Laplacian viscosity (m2/s) + KH_t_GME, & !< interface height diffusivities in t-columns [m2 s-1] + GME_coeff_h !< GME coeff. at h-points [m2 s-1] + real :: Ah ! biharmonic viscosity [m4 s-1] + real :: Kh ! Laplacian viscosity [m2 s-1] + real :: AhSm ! Smagorinsky biharmonic viscosity [m4 s-1] + real :: KhSm ! Smagorinsky Laplacian viscosity [m2 s-1] + real :: AhLth ! 2D Leith biharmonic viscosity [m4 s-1] + real :: KhLth ! 2D Leith Laplacian viscosity [m2 s-1] real :: mod_Leith ! nondimensional coefficient for divergence part of modified Leith ! viscosity. Here set equal to nondimensional Laplacian Leith constant. ! This is set equal to zero if modified Leith is not used. - real :: Shear_mag ! magnitude of the shear (1/s) - real :: vert_vort_mag ! magnitude of the vertical vorticity gradient (m-1 s-1) - real :: h2uq, h2vq ! temporary variables in units of H^2 (i.e. m2 or kg2 m-4). + real :: Shear_mag ! magnitude of the shear [s-1] + real :: vert_vort_mag ! magnitude of the vertical vorticity gradient [m-1 s-1] + real :: h2uq, h2vq ! temporary variables [H2 ~> m2 or kg2 m-4]. real :: hu, hv ! Thicknesses interpolated by arithmetic means to corner ! points; these are first interpolated to u or v velocity - ! points where masks are applied, in units of H (i.e. m or kg m-2). + ! points where masks are applied [H ~> m or kg m-2]. ! real :: hq ! harmonic mean of the harmonic means of the u- & v- ! ! point thicknesses, in H; This form guarantees that hq/hu < 4. - real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected (H) - real :: h_neglect3 ! h_neglect^3, in H3 + real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] + real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] real :: hrat_min ! minimum thicknesses at the 4 neighboring ! velocity points divided by the thickness at the stress ! point (h or q point) [nondim] real :: visc_bound_rem ! fraction of overall viscous bounds that ! remain to be applied [nondim] real :: Kh_scale ! A factor between 0 and 1 by which the horizontal - ! Laplacian viscosity is rescaled - real :: RoScl ! The scaling function for MEKE source term - real :: FatH ! abs(f) at h-point for MEKE source term (s-1) - real :: local_strain ! Local variable for interpolating computed strain rates (s-1). - real :: epsilon - real :: GME_coeff ! The GME (negative) viscosity coefficient (m2 s-1) - real :: GME_coeff_limiter ! Maximum permitted value of the GME coefficient (m2 s-1) - real :: FWfrac ! Fraction of maximum theoretical energy transfer to use when scaling GME coefficient + ! Laplacian viscosity is rescaled [nondim] + real :: RoScl ! The scaling function for MEKE source term [nondim] + real :: FatH ! abs(f) at h-point for MEKE source term [s-1] + real :: local_strain ! Local variable for interpolating computed strain rates [s-1]. + real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE. Otherwise =1. + real :: GME_coeff ! The GME (negative) viscosity coefficient [m2 s-1] + real :: GME_coeff_limiter ! Maximum permitted value of the GME coefficient [m2 s-1] + real :: FWfrac ! Fraction of maximum theoretical energy transfer to use when scaling GME coefficient real :: DY_dxBu, DX_dyBu - real :: H0 ! Depth used to scale down GME coefficient in shallow areas (m) + real :: H0 ! Depth used to scale down GME coefficient in shallow areas [m] logical :: rescale_Kh, legacy_bound logical :: find_FrictWork logical :: apply_OBC = .false. @@ -349,7 +351,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, inv_PI3 = 1.0/((4.0*atan(1.0))**3) inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI5 = inv_PI3 * inv_PI2 - epsilon = 1.e-7 Ah_h(:,:,:) = 0.0 Kh_h(:,:,:) = 0.0 @@ -475,8 +476,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP sh_xx_bt, sh_xy_bt, dvdx_bt, dudy_bt, & !$OMP bhstr_xx, bhstr_xy,FatH,RoScl, hu, hv, h_u, h_v, & !$OMP vort_xy,vort_xy_dx,vort_xy_dy,Vort_mag,AhLth,KhLth, & - !$OMP div_xx, div_xx_dx, div_xx_dy,local_strain, & - !$OMP Shear_mag, h2uq, h2vq, Kh_scale, hrat_min) + !$OMP div_xx, div_xx_dx, div_xx_dy, local_strain, & + !$OMP meke_res_fn, & + !$OMP Shear_mag, h2uq, h2vq, hq, Kh_scale, hrat_min) do k=1,nz ! The following are the forms of the horizontal tension and horizontal @@ -485,11 +487,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Calculate horizontal tension do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - dudx(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u(I,j,k) - & - G%IdyCu(I-1,j) * u(I-1,j,k)) - dvdy(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v(i,J,k) - & - G%IdxCv(i,J-1) * v(i,J-1,k)) - sh_xx(i,j) = dudx(i,j) - dvdy(i,j) + dudx(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u(I,j,k) - & + G%IdyCu(I-1,j) * u(I-1,j,k)) + dvdy(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v(i,J,k) - & + G%IdxCv(i,J-1) * v(i,J-1,k)) + sh_xx(i,j) = dudx(i,j) - dvdy(i,j) enddo ; enddo ! Components for the shearing strain @@ -567,7 +569,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - ! There are extra wide halos here to accomodate the cross-corner-point + ! There are extra wide halos here to accommodate the cross-corner-point ! OBC projections, but they might not be necessary if the accelerations ! are always zeroed out at OBC points, in which case the i-loop below ! becomes do i=is-1,ie+1. -RWH @@ -801,6 +803,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! CS%Leith_Kh + meke_res_fn = 1. + do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then Shear_mag = sqrt(sh_xx(i,j)*sh_xx(i,j) + & @@ -828,10 +832,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%Leith_Kh) Kh = max( Kh, CS%Laplac3_const_xx(i,j) * vert_vort_mag*inv_PI3) ! All viscosity contributions above are subject to resolution scaling if (rescale_Kh) Kh = VarMix%Res_fn_h(i,j) * Kh + if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_h(i,j) ! Older method of bounding for stability if (legacy_bound) Kh = min(Kh, CS%Kh_Max_xx(i,j)) Kh = max( Kh, CS%Kh_bg_min ) ! Place a floor on the viscosity, if desired. - if (use_MEKE_Ku) Kh = Kh + MEKE%Ku(i,j) ! *Add* the MEKE contribution (might be negative) + if (use_MEKE_Ku) Kh = Kh + MEKE%Ku(i,j) * meke_res_fn ! *Add* the MEKE contribution (might be negative) if (CS%anisotropic) Kh = Kh + CS%Kh_aniso * ( 1. - CS%n1n2_h(i,j)**2 ) ! *Add* the tension component ! of anisotropic viscosity @@ -874,7 +879,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, AhSm = CS%Biharm_const_xx(i,j) * Shear_mag endif endif - if (CS%Leith_Ah) AhLth = CS%Biharm5_const_xx(i,j) * vert_vort_mag*inv_PI5 + if (CS%Leith_Ah) AhLth = CS%biharm5_const_xx(i,j) * vert_vort_mag * inv_PI5 Ah = MAX(MAX(CS%Ah_bg_xx(i,j), AhSm),AhLth) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & Ah = MIN(Ah, CS%Ah_Max_xx(i,j)) @@ -935,6 +940,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ; endif endif + meke_res_fn = 1. + do J=js-1,Jeq ; do I=is-1,Ieq if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then Shear_mag = sqrt(sh_xy(I,J)*sh_xy(I,J) + & @@ -987,13 +994,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%Leith_Kh) Kh = max( Kh, CS%Laplac3_const_xy(I,J) * vert_vort_mag*inv_PI3) ! All viscosity contributions above are subject to resolution scaling if (rescale_Kh) Kh = VarMix%Res_fn_q(i,j) * Kh + if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_q(i,j) ! Older method of bounding for stability if (legacy_bound) Kh = min(Kh, CS%Kh_Max_xy(i,j)) Kh = max( Kh, CS%Kh_bg_min ) ! Place a floor on the viscosity, if desired. if (use_MEKE_Ku) then ! *Add* the MEKE contribution (might be negative) Kh = Kh + 0.25*( (MEKE%Ku(I,J)+MEKE%Ku(I+1,J+1)) & - +(MEKE%Ku(I+1,J)+MEKE%Ku(I,J+1)) ) + +(MEKE%Ku(I+1,J)+MEKE%Ku(I,J+1)) ) * meke_res_fn endif + ! Older method of bounding for stability if (CS%anisotropic) Kh = Kh + CS%Kh_aniso * CS%n1n2_q(I,J)**2 ! *Add* the shear component ! of anisotropic viscosity @@ -1390,6 +1399,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) real :: Ah ! biharmonic horizontal viscosity [m4 s-1] real :: Kh_vel_scale ! this speed [m s-1] times grid spacing gives Lap visc real :: Ah_vel_scale ! this speed [m s-1] times grid spacing cubed gives bih visc + real :: Ah_time_scale ! damping time-scale for biharmonic visc real :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant real :: Leith_Lap_const ! nondimensional Laplacian Leith constant @@ -1466,18 +1476,18 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) "The minimum value allowed for Laplacian horizontal viscosity, KH.", & units = "m2 s-1", default=0.0) call get_param(param_file, mdl, "KH_VEL_SCALE", Kh_vel_scale, & - "The velocity scale which is multiplied by the grid \n"//& - "spacing to calculate the Laplacian viscosity. \n"//& - "The final viscosity is the largest of this scaled \n"//& + "The velocity scale which is multiplied by the grid "//& + "spacing to calculate the Laplacian viscosity. "//& + "The final viscosity is the largest of this scaled "//& "viscosity, the Smagorinsky and Leith viscosities, and KH.", & units="m s-1", default=0.0) call get_param(param_file, mdl, "KH_SIN_LAT", Kh_sin_lat, & - "The amplitude of a latidutinally-dependent background\n"//& + "The amplitude of a latitudinally-dependent background "//& "viscosity of the form KH_SIN_LAT*(SIN(LAT)**KH_PWR_OF_SINE).", & units = "m2 s-1", default=0.0) if (Kh_sin_lat>0. .or. get_all) & call get_param(param_file, mdl, "KH_PWR_OF_SINE", Kh_pwr_of_sine, & - "The power used to raise SIN(LAT) when using a latidutinally-\n"//& + "The power used to raise SIN(LAT) when using a latitudinally "//& "dependent background viscosity.", & units = "nondim", default=4.0) @@ -1486,16 +1496,25 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) default=.false.) if (CS%Smagorinsky_Kh .or. get_all) & call get_param(param_file, mdl, "SMAG_LAP_CONST", Smag_Lap_const, & - "The nondimensional Laplacian Smagorinsky constant, \n"//& + "The nondimensional Laplacian Smagorinsky constant, "//& "often 0.15.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Kh) call get_param(param_file, mdl, "LEITH_KH", CS%Leith_Kh, & "If true, use a Leith nonlinear eddy viscosity.", & default=.false.) + + call get_param(param_file, mdl, "MODIFIED_LEITH", CS%Modified_Leith, & + "If true, add a term to Leith viscosity which is "//& + "proportional to the gradient of divergence.", & + default=.false.) + call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & + "If true, the viscosity contribution from MEKE is scaled by "//& + "the resolution function.", default=.false.) + if (CS%Leith_Kh .or. get_all) then call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & - "The nondimensional Laplacian Leith constant, \n"//& + "The nondimensional Laplacian Leith constant, "//& "often set to 1.0", units="nondim", default=0.0, & fail_if_missing = CS%Leith_Kh) call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, & @@ -1515,14 +1534,14 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) default=.false.) endif call get_param(param_file, mdl, "BOUND_KH", CS%bound_Kh, & - "If true, the Laplacian coefficient is locally limited \n"//& + "If true, the Laplacian coefficient is locally limited "//& "to be stable.", default=.true.) call get_param(param_file, mdl, "BETTER_BOUND_KH", CS%better_bound_Kh, & - "If true, the Laplacian coefficient is locally limited \n"//& + "If true, the Laplacian coefficient is locally limited "//& "to be stable with a better bounding than just BOUND_KH.", & default=CS%bound_Kh) call get_param(param_file, mdl, "ANISOTROPIC_VISCOSITY", CS%anisotropic, & - "If true, allow anistropic viscosity in the Laplacian\n"//& + "If true, allow anistropic viscosity in the Laplacian "//& "horizontal viscosity.", default=.false.) endif if (CS%anisotropic .or. get_all) then @@ -1538,19 +1557,19 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) select case (aniso_mode) case (0) call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for\n"//& - "horizont viscosity. n1,n2 are the i,j components relative\n"//& + "The vector pointing in the direction of anistropy for "//& + "horizont viscosity. n1,n2 are the i,j components relative "//& "to the grid.", units = "nondim", fail_if_missing=.true.) case (1) call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for\n"//& - "horizont viscosity. n1,n2 are the i,j components relative\n"//& + "The vector pointing in the direction of anistropy for "//& + "horizont viscosity. n1,n2 are the i,j components relative "//& "to the spherical coordinates.", units = "nondim", fail_if_missing=.true.) end select endif call get_param(param_file, mdl, "BIHARMONIC", CS%biharmonic, & - "If true, use a biharmonic horizontal viscosity. \n"//& + "If true, use a biharmonic horizontal viscosity. "//& "BIHARMONIC may be used with LAPLACIAN.", & default=.true.) if (CS%biharmonic .or. get_all) then @@ -1558,82 +1577,89 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) "The background biharmonic horizontal viscosity.", & units = "m4 s-1", default=0.0) call get_param(param_file, mdl, "AH_VEL_SCALE", Ah_vel_scale, & - "The velocity scale which is multiplied by the cube of \n"//& - "the grid spacing to calculate the biharmonic viscosity. \n"//& - "The final viscosity is the largest of this scaled \n"//& + "The velocity scale which is multiplied by the cube of "//& + "the grid spacing to calculate the biharmonic viscosity. "//& + "The final viscosity is the largest of this scaled "//& "viscosity, the Smagorinsky and Leith viscosities, and AH.", & units="m s-1", default=0.0) + call get_param(param_file, mdl, "AH_TIME_SCALE", Ah_time_scale, & + "A time scale whose inverse is multiplied by the fourth "//& + "power of the grid spacing to calculate biharmonic viscosity. "//& + "The final viscosity is the largest of all viscosity "//& + "formulations in use. 0.0 means that it's not used.", & + units="s", default=0.0) call get_param(param_file, mdl, "SMAGORINSKY_AH", CS%Smagorinsky_Ah, & - "If true, use a biharmonic Smagorinsky nonlinear eddy \n"//& + "If true, use a biharmonic Smagorinsky nonlinear eddy "//& "viscosity.", default=.false.) call get_param(param_file, mdl, "LEITH_AH", CS%Leith_Ah, & - "If true, use a biharmonic Leith nonlinear eddy \n"//& + "If true, use a biharmonic Leith nonlinear eddy "//& "viscosity.", default=.false.) call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, & - "If true, the biharmonic coefficient is locally limited \n"//& + "If true, the biharmonic coefficient is locally limited "//& "to be stable.", default=.true.) call get_param(param_file, mdl, "BETTER_BOUND_AH", CS%better_bound_Ah, & - "If true, the biharmonic coefficient is locally limited \n"//& + "If true, the biharmonic coefficient is locally limited "//& "to be stable with a better bounding than just BOUND_AH.", & default=CS%bound_Ah) if (CS%Smagorinsky_Ah .or. get_all) then call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & - "The nondimensional biharmonic Smagorinsky constant, \n"//& + "The nondimensional biharmonic Smagorinsky constant, "//& "typically 0.015 - 0.06.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Ah) call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.) call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, & - "If true use a viscosity that increases with the square \n"//& - "of the velocity shears, so that the resulting viscous \n"//& - "drag is of comparable magnitude to the Coriolis terms \n"//& - "when the velocity differences between adjacent grid \n"//& - "points is 0.5*BOUND_CORIOLIS_VEL. The default is the \n"//& + "If true use a viscosity that increases with the square "//& + "of the velocity shears, so that the resulting viscous "//& + "drag is of comparable magnitude to the Coriolis terms "//& + "when the velocity differences between adjacent grid "//& + "points is 0.5*BOUND_CORIOLIS_VEL. The default is the "//& "value of BOUND_CORIOLIS (or false).", default=bound_Cor_def) if (CS%bound_Coriolis .or. get_all) then call get_param(param_file, mdl, "MAXVEL", maxvel, default=3.0e8) bound_Cor_vel = maxvel call get_param(param_file, mdl, "BOUND_CORIOLIS_VEL", bound_Cor_vel, & - "The velocity scale at which BOUND_CORIOLIS_BIHARM causes \n"//& - "the biharmonic drag to have comparable magnitude to the \n"//& + "The velocity scale at which BOUND_CORIOLIS_BIHARM causes "//& + "the biharmonic drag to have comparable magnitude to the "//& "Coriolis acceleration. The default is set by MAXVEL.", & units="m s-1", default=maxvel) endif endif + if (CS%Leith_Ah .or. get_all) & - call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, & - "The nondimensional biharmonic Leith constant, \n"//& + call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, & + "The nondimensional biharmonic Leith constant, "//& "typical values are thus far undetermined.", units="nondim", default=0.0, & fail_if_missing = CS%Leith_Ah) endif call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, & - "If true, use Use the land mask for the computation of thicknesses \n"//& - "at velocity locations. This eliminates the dependence on arbitrary \n"//& - "values over land or outside of the domain. Default is False in order to \n"//& - "maintain answers with legacy experiments but should be changed to True \n"//& + "If true, use Use the land mask for the computation of thicknesses "//& + "at velocity locations. This eliminates the dependence on arbitrary "//& + "values over land or outside of the domain. Default is False in order to "//& + "maintain answers with legacy experiments but should be changed to True "//& "for new experiments.", default=.false.) if (CS%better_bound_Ah .or. CS%better_bound_Kh .or. get_all) & call get_param(param_file, mdl, "HORVISC_BOUND_COEF", CS%bound_coef, & - "The nondimensional coefficient of the ratio of the \n"//& - "viscosity bounds to the theoretical maximum for \n"//& + "The nondimensional coefficient of the ratio of the "//& + "viscosity bounds to the theoretical maximum for "//& "stability without considering other terms.", units="nondim", & default=0.8) call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & - "If true, no slip boundary conditions are used; otherwise \n"//& - "free slip boundary conditions are assumed. The \n"//& - "implementation of the free slip BCs on a C-grid is much \n"//& - "cleaner than the no slip BCs. The use of free slip BCs \n"//& - "is strongly encouraged, and no slip BCs are not used with \n"//& + "If true, no slip boundary conditions are used; otherwise "//& + "free slip boundary conditions are assumed. The "//& + "implementation of the free slip BCs on a C-grid is much "//& + "cleaner than the no slip BCs. The use of free slip BCs "//& + "is strongly encouraged, and no slip BCs are not used with "//& "the biharmonic viscosity.", default=.false.) call get_param(param_file, mdl, "USE_KH_BG_2D", CS%use_Kh_bg_2d, & - "If true, read a file containing 2-d background harmonic \n"//& + "If true, read a file containing 2-d background harmonic "//& "viscosities. The final viscosity is the maximum of the other "//& "terms and this background value.", default=.false.) @@ -1651,12 +1677,12 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) if (CS%bound_Kh .or. CS%bound_Ah .or. CS%better_bound_Kh .or. CS%better_bound_Ah) & call get_param(param_file, mdl, "DT", dt, & - "The (baroclinic) dynamics time step.", units = "s", & + "The (baroclinic) dynamics time step.", units="s", & fail_if_missing=.true.) if (CS%no_slip .and. CS%biharmonic) & call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & - "at the same time in MOM.") + "at the same time in MOM.") if (.not.(CS%Laplacian .or. CS%biharmonic)) then ! Only issue inviscid warning if not in single column mode (usually 2x2 domain) @@ -1875,8 +1901,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) if (CS%Smagorinsky_Ah) then CS%Biharm_const_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2) if (CS%bound_Coriolis) then - fmax = MAX(abs(G%CoriolisBu(I-1,J-1)), abs(G%CoriolisBu(I,J-1)), & - abs(G%CoriolisBu(I-1,J)), abs(G%CoriolisBu(I,J))) + fmax = US%s_to_T*MAX(abs(G%CoriolisBu(I-1,J-1)), abs(G%CoriolisBu(I,J-1)), & + abs(G%CoriolisBu(I-1,J)), abs(G%CoriolisBu(I,J))) CS%Biharm_const2_xx(i,j) = (grid_sp_h2 * grid_sp_h2 * grid_sp_h2) * & (fmax * BoundCorConst) endif @@ -1885,6 +1911,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) CS%biharm5_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h2) endif CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) + if (Ah_time_scale>0.) CS%Ah_bg_xx(i,j) = & + MAX(CS%Ah_bg_xx(i,j), (grid_sp_h2 * grid_sp_h2) / Ah_time_scale) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then CS%Ah_Max_xx(i,j) = Ah_Limit * (grid_sp_h2 * grid_sp_h2) CS%Ah_bg_xx(i,j) = MIN(CS%Ah_bg_xx(i,j), CS%Ah_Max_xx(i,j)) @@ -1906,6 +1934,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) + if (Ah_time_scale>0.) CS%Ah_bg_xy(i,j) = & + MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then CS%Ah_Max_xy(I,J) = Ah_Limit * (grid_sp_q2 * grid_sp_q2) CS%Ah_bg_xy(I,J) = MIN(CS%Ah_bg_xy(I,J), CS%Ah_Max_xy(I,J)) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 27115dec67..fb35d5b45c 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -108,10 +108,6 @@ module MOM_internal_tides !< The internal wave energy density as a function of (i,j,angle); temporary for restart real, allocatable, dimension(:) :: frequency !< The frequency of each band [s-1]. - !### Delete later - real :: int_tide_source_x !< X Location of generation site for internal tide testing - real :: int_tide_source_y !< Y Location of generation site for internal tide testing - type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. type(wave_structure_CS), pointer :: wave_structure_CSp => NULL() @@ -215,10 +211,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & frac_per_sector = 1.0 / real(CS%nAngle * CS%nMode * CS%nFreq) do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie f2 = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) - !### For rotational symmetry this should be - ! f2 = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - ! (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + & dt*frac_per_sector*(1-CS%q_itides)*TKE_itidal_input(i,j) @@ -228,10 +221,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & a = CS%energized_angle do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie f2 = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) - !### For rotational symmetry this should be - ! f2 = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - ! (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + & dt*frac_per_sector**(1-CS%q_itides)*TKE_itidal_input(i,j) @@ -427,11 +417,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=jsd,jed ; do i=isd,ied id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging ! Calculate horizontal phase velocity magnitudes - f2 = 0.25*US%s_to_T**2*(G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J)**2 + & - G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J-1)**2 ) - !### For rotational symmetry this should be - ! f2 = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - ! (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + f2 = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) c_phase = 0.0 if (Kmag2 > 0.0) then @@ -1821,7 +1808,7 @@ subroutine teleport(En, NAngle, CS, G, LB) end subroutine teleport -!> Rotates points in the halos where required to accomodate +!> Rotates points in the halos where required to accommodate !! changes in grid orientation, such as at the tripolar fold. subroutine correct_halo_rotation(En, test, G, NAngle) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -2204,13 +2191,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "INTERNAL_TIDE_FREQS", num_freq, & - "The number of distinct internal tide frequency bands \n"//& + "The number of distinct internal tide frequency bands "//& "that will be calculated.", default=1) call get_param(param_file, mdl, "INTERNAL_TIDE_MODES", num_mode, & - "The number of distinct internal tide modes \n"//& + "The number of distinct internal tide modes "//& "that will be calculated.", default=1) call get_param(param_file, mdl, "INTERNAL_TIDE_ANGLES", num_angle, & - "The number of angular resolution bands for the internal \n"//& + "The number of angular resolution bands for the internal "//& "tide calculations.", default=24) if (use_int_tides) then @@ -2240,34 +2227,34 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", CS%decay_rate, & - "The rate at which internal tide energy is lost to the \n"//& + "The rate at which internal tide energy is lost to the "//& "interior ocean internal wave field.", units="s-1", default=0.0) call get_param(param_file, mdl, "INTERNAL_TIDE_VOLUME_BASED_CFL", CS%vol_CFL, & - "If true, use the ratio of the open face lengths to the \n"//& - "tracer cell areas when estimating CFL numbers in the \n"//& + "If true, use the ratio of the open face lengths to the "//& + "tracer cell areas when estimating CFL numbers in the "//& "internal tide code.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_CORNER_ADVECT", CS%corner_adv, & - "If true, internal tide ray-tracing advection uses a \n"//& - " corner-advection scheme rather than PPM.\n", default=.false.) + "If true, internal tide ray-tracing advection uses a "//& + "corner-advection scheme rather than PPM.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_SIMPLE_2ND_PPM", CS%simple_2nd, & - "If true, CONTINUITY_PPM uses a simple 2nd order \n"//& - "(arithmetic mean) interpolation of the edge values. \n"//& - "This may give better PV conservation propterties. While \n"//& - "it formally reduces the accuracy of the continuity \n"//& - "solver itself in the strongly advective limit, it does \n"//& - "not reduce the overall order of accuracy of the dynamic \n"//& + "If true, CONTINUITY_PPM uses a simple 2nd order "//& + "(arithmetic mean) interpolation of the edge values. "//& + "This may give better PV conservation properties. While "//& + "it formally reduces the accuracy of the continuity "//& + "solver itself in the strongly advective limit, it does "//& + "not reduce the overall order of accuracy of the dynamic "//& "core.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_UPWIND_1ST", CS%upwind_1st, & - "If true, the internal tide ray-tracing advection uses \n"//& - "1st-order upwind advection. This scheme is highly \n"//& - "continuity solver. This scheme is highly \n"//& + "If true, the internal tide ray-tracing advection uses "//& + "1st-order upwind advection. This scheme is highly "//& + "continuity solver. This scheme is highly "//& "diffusive but may be useful for debugging.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_BACKGROUND_DRAG", & - CS%apply_background_drag, "If true, the internal tide \n"//& + CS%apply_background_drag, "If true, the internal tide "//& "ray-tracing advection uses a background drag term as a sink.",& default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_QUAD_DRAG", CS%apply_bottom_drag, & - "If true, the internal tide ray-tracing advection uses \n"//& + "If true, the internal tide ray-tracing advection uses "//& "a quadratic bottom drag term as a sink.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_WAVE_DRAG", CS%apply_wave_drag, & "If true, apply scattering due to small-scale roughness as a sink.", & @@ -2276,22 +2263,22 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "If true, apply wave breaking as a sink.", & default=.false.) call get_param(param_file, mdl, "CDRAG", CS%cdrag, & - "CDRAG is the drag coefficient relating the magnitude of \n"//& + "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", units="nondim", & default=0.003) call get_param(param_file, mdl, "INTERNAL_TIDE_ENERGIZED_ANGLE", CS%energized_angle, & - "If positive, only one angular band of the internal tides \n"//& + "If positive, only one angular band of the internal tides "//& "gets all of the energy. (This is for debugging.)", default=-1) call get_param(param_file, mdl, "USE_PPM_ANGULAR", CS%use_PPMang, & - "If true, use PPM for advection of energy in angular \n"//& - "space.", default=.false.) + "If true, use PPM for advection of energy in angular space.", & + default=.false.) call get_param(param_file, mdl, "GAMMA_ITIDES", CS%q_itides, & - "The fraction of the internal tidal energy that is \n"//& - "dissipated locally with INT_TIDE_DISSIPATION. \n"//& + "The fraction of the internal tidal energy that is "//& + "dissipated locally with INT_TIDE_DISSIPATION. "//& "THIS NAME COULD BE BETTER.", & units="nondim", default=0.3333) call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & - "A topographic wavenumber used with INT_TIDE_DISSIPATION. \n"//& + "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & units="m-1", default=8.e-4*atan(1.0)) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & @@ -2317,7 +2304,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Compute the fixed part of the bottom drag loss from baroclinic modes call get_param(param_file, mdl, "H2_FILE", h2_file, & - "The path to the file containing the sub-grid-scale \n"//& + "The path to the file containing the sub-grid-scale "//& "topographic roughness amplitude with INT_TIDE_DISSIPATION.", & fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) @@ -2336,7 +2323,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in prescribed coast/ridge/shelf angles from file call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & - "The path to the file containing the local angle of \n"//& + "The path to the file containing the local angle of "//& "the coastline/ridge/shelf with respect to the equator.", & fail_if_missing=.false.) filename = trim(CS%inputdir) // trim(refl_angle_file) @@ -2424,12 +2411,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !call MOM_read_data(filename, 'dx_Cv', G%dx_Cv, G%domain, timelevel=1) !call pass_var(G%dx_Cv,G%domain) - ! For debugging - delete later - call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & - "X Location of generation site for internal tide", default=1.) - call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & - "Y Location of generation site for internal tide", default=1.) - ! Register maps of reflection parameters CS%id_refl_ang = register_diag_field('ocean_model', 'refl_angle', diag%axesT1, & Time, 'Local angle of coastline/ridge/shelf with respect to equator', 'rad') @@ -2456,7 +2437,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) Time, 'Interior and bottom drag internal tide decay timescale', 's-1') !Register 2-D energy input into internal tides CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & - Time, 'Conversion from barotropic to baroclinic tide, \n'//& + Time, 'Conversion from barotropic to baroclinic tide, '//& 'a fraction of which goes into rays', 'W m-2') ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 9977cf9c1f..3a7d2a01a1 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -88,22 +88,22 @@ module MOM_lateral_mixing_coeffs Rd_dx_h => NULL() !< Deformation radius over grid spacing [nondim] real, dimension(:,:,:), pointer :: & - slope_x => NULL(), & !< Zonal isopycnal slope (non-dimensional) - slope_y => NULL(), & !< Meridional isopycnal slope (non-dimensional) - N2_u => NULL(), & !< Brunt-Vaisala frequency at u-points (s-2) - N2_v => NULL(), & !< Brunt-Vaisala frequency at v-points (s-2) - ebt_struct => NULL() !< Vertical structure function to scale diffusivities with (non-dim) + slope_x => NULL(), & !< Zonal isopycnal slope [nondim] + slope_y => NULL(), & !< Meridional isopycnal slope [nondim] + N2_u => NULL(), & !< Brunt-Vaisala frequency at u-points [s-2] + N2_v => NULL(), & !< Brunt-Vaisala frequency at v-points [s-2] + ebt_struct => NULL() !< Vertical structure function to scale diffusivities with [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & - Laplac3_const_u !< Laplacian metric-dependent constants (nondim) + Laplac3_const_u !< Laplacian metric-dependent constants [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & - Laplac3_const_v !< Laplacian metric-dependent constants (nondim) + Laplac3_const_v !< Laplacian metric-dependent constants [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & - KH_u_QG !< QG Leith GM coefficient at u-points (m2 s-1) + KH_u_QG !< QG Leith GM coefficient at u-points [m2 s-1] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & - KH_v_QG !< QG Leith GM coefficient at v-points (m2 s-1) + KH_v_QG !< QG Leith GM coefficient at v-points [m2 s-1] ! Parameters logical :: use_Visbeck !< Use Visbeck formulation for thickness diffusivity @@ -180,7 +180,8 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp, modal_structure=CS%ebt_struct) else ! Use EBT to get vertical structure first and then re-calculate cg1 using first baroclinic mode - call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp, modal_structure=CS%ebt_struct, use_ebt_mode=.true.) + call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp, modal_structure=CS%ebt_struct, & + use_ebt_mode=.true.) call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp) endif call pass_var(CS%ebt_struct, G%Domain) @@ -729,43 +730,51 @@ end subroutine calc_slope_functions_using_just_e !> Calculates the Leith Laplacian and bi-harmonic viscosity coefficients subroutine calc_QG_Leith_viscosity(CS, G, GV, h, k, div_xx_dx, div_xx_dy, vort_xy_dx, vort_xy_dy) type(VarMix_CS), pointer :: CS !< Variable mixing coefficients - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. -! real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal flow (m s-1) -! real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional flow (m s-1) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: h !< Layer thickness (m or kg m-2) - integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) (m-1 s-1) - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: div_xx_dy !< y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) (m-1 s-1) - real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vort_xy_dx !< x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) (m-1 s-1) - real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: vort_xy_dy !< y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) (m-1 s-1) -! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Kh_h !< Leith Laplacian viscosity at h-points (m2 s-1) -! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Kh_q !< Leith Laplacian viscosity at q-points (m2 s-1) -! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Ah_h !< Leith bi-harmonic viscosity at h-points (m4 s-1) -! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Ah_q !< Leith bi-harmonic viscosity at q-points (m4 s-1) +! real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal flow [m s-1] +! real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional flow [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence + !! (d/dx(du/dx + dv/dy)) [m-1 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: div_xx_dy !< y-derivative of horizontal divergence + !! (d/dy(du/dx + dv/dy)) [m-1 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vort_xy_dx !< x-derivative of vertical vorticity + !! (d/dx(dv/dx - du/dy)) [m-1 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: vort_xy_dy !< y-derivative of vertical vorticity + !! (d/dy(dv/dx - du/dy)) [m-1 s-1] +! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Kh_h !< Leith Laplacian viscosity + !! at h-points [m2 s-1] +! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Kh_q !< Leith Laplacian viscosity + !! at q-points [m2 s-1] +! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Ah_h !< Leith bi-harmonic viscosity + !! at h-points [m4 s-1] +! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Ah_q !< Leith bi-harmonic viscosity + !! at q-points [m4 s-1] ! Local variables -! real, dimension(SZIB_(G),SZJB_(G)) :: vort_xy, & ! Vertical vorticity (dv/dx - du/dy) (s-1) -! dudy, & ! Meridional shear of zonal velocity (s-1) -! dvdx ! Zonal shear of meridional velocity (s-1) +! real, dimension(SZIB_(G),SZJB_(G)) :: vort_xy, & ! Vertical vorticity (dv/dx - du/dy) [s-1] +! dudy, & ! Meridional shear of zonal velocity [s-1] +! dvdx ! Zonal shear of meridional velocity [s-1] real, dimension(SZI_(G),SZJB_(G)) :: & -! vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) (m-1 s-1) -! div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) (m-1 s-1) - dslopey_dz, & ! z-derivative of y-slope at v-points (m-1) - h_at_v, & ! Thickness at v-points (m or kg m-2) - beta_v, & ! Beta at v-points (m-1 s-1) - grad_vort_mag_v, & ! mag. of vort. grad. at v-points (s-1) - grad_div_mag_v ! mag. of div. grad. at v-points (s-1) +! vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [m-1 s-1] +! div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [m-1 s-1] + dslopey_dz, & ! z-derivative of y-slope at v-points [m-1] + h_at_v, & ! Thickness at v-points [H ~> m or kg m-2] + beta_v, & ! Beta at v-points [m-1 s-1] + grad_vort_mag_v, & ! mag. of vort. grad. at v-points [s-1] + grad_div_mag_v ! mag. of div. grad. at v-points [s-1] real, dimension(SZIB_(G),SZJ_(G)) :: & -! vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) (m-1 s-1) -! div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) (m-1 s-1) +! vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [m-1 s-1] +! div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [m-1 s-1] dslopex_dz, & ! z-derivative of x-slope at u-points (m-1) - h_at_u, & ! Thickness at u-points (m or kg m-2) - beta_u, & ! Beta at u-points (m-1 s-1) - grad_vort_mag_u, & ! mag. of vort. grad. at u-points (s-1) - grad_div_mag_u ! mag. of div. grad. at u-points (s-1) -! real, dimension(SZI_(G),SZJ_(G)) :: div_xx ! Estimate of horizontal divergence at h-points (s-1) + h_at_u, & ! Thickness at u-points [H ~> m or kg m-2] + beta_u, & ! Beta at u-points [m-1 s-1] + grad_vort_mag_u, & ! mag. of vort. grad. at u-points [s-1] + grad_div_mag_u ! mag. of div. grad. at u-points [s-1] +! real, dimension(SZI_(G),SZJ_(G)) :: div_xx ! Estimate of horizontal divergence at h-points [s-1] ! real :: mod_Leith, DY_dxBu, DX_dyBu, vert_vort_mag real :: h_at_slope_above, h_at_slope_below, Ih, f integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq,nz @@ -922,45 +931,45 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_VARIABLE_MIXING", CS%use_variable_mixing,& - "If true, the variable mixing code will be called. This \n"//& - "allows diagnostics to be created even if the scheme is \n"//& - "not used. If KHTR_SLOPE_CFF>0 or KhTh_Slope_Cff>0, \n"//& - "this is set to true regardless of what is in the \n"//& + "If true, the variable mixing code will be called. This "//& + "allows diagnostics to be created even if the scheme is "//& + "not used. If KHTR_SLOPE_CFF>0 or KhTh_Slope_Cff>0, "//& + "this is set to true regardless of what is in the "//& "parameter file.", default=.false.) call get_param(param_file, mdl, "USE_VISBECK", CS%use_Visbeck,& "If true, use the Visbeck et al. (1997) formulation for \n"//& "thickness diffusivity.", default=.false.) call get_param(param_file, mdl, "RESOLN_SCALED_KH", CS%Resoln_scaled_Kh, & - "If true, the Laplacian lateral viscosity is scaled away \n"//& - "when the first baroclinic deformation radius is well \n"//& + "If true, the Laplacian lateral viscosity is scaled away "//& + "when the first baroclinic deformation radius is well "//& "resolved.", default=.false.) call get_param(param_file, mdl, "RESOLN_SCALED_KHTH", CS%Resoln_scaled_KhTh, & - "If true, the interface depth diffusivity is scaled away \n"//& - "when the first baroclinic deformation radius is well \n"//& + "If true, the interface depth diffusivity is scaled away "//& + "when the first baroclinic deformation radius is well "//& "resolved.", default=.false.) call get_param(param_file, mdl, "RESOLN_SCALED_KHTR", CS%Resoln_scaled_KhTr, & - "If true, the epipycnal tracer diffusivity is scaled \n"//& - "away when the first baroclinic deformation radius is \n"//& + "If true, the epipycnal tracer diffusivity is scaled "//& + "away when the first baroclinic deformation radius is "//& "well resolved.", default=.false.) call get_param(param_file, mdl, "RESOLN_USE_EBT", CS%Resoln_use_ebt, & - "If true, uses the equivalent barotropic wave speed instead\n"//& + "If true, uses the equivalent barotropic wave speed instead "//& "of first baroclinic wave for calculating the resolution fn.",& default=.false.) call get_param(param_file, mdl, "KHTH_USE_EBT_STRUCT", CS%khth_use_ebt_struct, & - "If true, uses the equivalent barotropic structure\n"//& + "If true, uses the equivalent barotropic structure "//& "as the vertical structure of thickness diffusivity.",& default=.false.) call get_param(param_file, mdl, "KHTH_SLOPE_CFF", KhTh_Slope_Cff, & - "The nondimensional coefficient in the Visbeck formula \n"//& + "The nondimensional coefficient in the Visbeck formula "//& "for the interface depth diffusivity", units="nondim", & default=0.0) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", KhTr_Slope_Cff, & - "The nondimensional coefficient in the Visbeck formula \n"//& + "The nondimensional coefficient in the Visbeck formula "//& "for the epipycnal tracer diffusivity", units="nondim", & default=0.0) call get_param(param_file, mdl, "USE_STORED_SLOPES", CS%use_stored_slopes,& - "If true, the isopycnal slopes are calculated once and\n"//& - "stored for re-use. This uses more memory but avoids calling\n"//& + "If true, the isopycnal slopes are calculated once and "//& + "stored for re-use. This uses more memory but avoids calling "//& "the equation of state more times than should be necessary.", & default=.false.) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", use_FGNV_streamfn, & @@ -982,7 +991,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) then in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & - "The depth below which N2 is monotonized to avoid stratification\n"//& + "The depth below which N2 is monotonized to avoid stratification "//& "artifacts from altering the equivalent barotropic mode structure.",& units='m', default=2000.) allocate(CS%ebt_struct(isd:ied,jsd:jed,G%ke)) ; CS%ebt_struct(:,:,:) = 0.0 @@ -991,8 +1000,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then CS%calculate_Eady_growth_rate = .true. call get_param(param_file, mdl, "VISBECK_MAX_SLOPE", CS%Visbeck_S_max, & - "If non-zero, is an upper bound on slopes used in the\n"// & - "Visbeck formula for diffusivity. This does not affect the\n"// & + "If non-zero, is an upper bound on slopes used in the "//& + "Visbeck formula for diffusivity. This does not affect the "//& "isopycnal slope calculation used within thickness diffusion.", & units="nondim", default=0.0) endif @@ -1004,7 +1013,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%N2_u(IsdB:IedB,jsd:jed,G%ke+1)) ; CS%N2_u(:,:,:) = 0.0 allocate(CS%N2_v(isd:ied,JsdB:JedB,G%ke+1)) ; CS%N2_v(:,:,:) = 0.0 call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & - "A diapycnal diffusivity that is used to interpolate \n"//& + "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & default=1.0e-6, scale=US%m_to_Z**2) !### Add units argument. endif @@ -1018,7 +1027,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%id_SN_v = register_diag_field('ocean_model', 'SN_v', diag%axesCv1, Time, & 'Inverse eddy time-scale, S*N, at v-points', 's-1') call get_param(param_file, mdl, "VARMIX_KTOP", CS%VarMix_Ktop, & - "The layer number at which to start vertical integration \n"//& + "The layer number at which to start vertical integration "//& "of S*N for purposes of finding the Eady growth rate.", & units="nondim", default=2) endif @@ -1028,8 +1037,19 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "VISBECK_L_SCALE", CS%Visbeck_L_scale, & "The fixed length scale in the Visbeck formula.", units="m", & default=0.0) - allocate(CS%L2u(IsdB:IedB,jsd:jed)) ; CS%L2u(:,:) = CS%Visbeck_L_scale**2 - allocate(CS%L2v(isd:ied,JsdB:JedB)) ; CS%L2v(:,:) = CS%Visbeck_L_scale**2 + allocate(CS%L2u(IsdB:IedB,jsd:jed)) ; CS%L2u(:,:) = 0.0 + allocate(CS%L2v(isd:ied,JsdB:JedB)) ; CS%L2v(:,:) = 0.0 + if (CS%Visbeck_L_scale<0) then + do j=js,je ; do I=is-1,Ieq + CS%L2u(I,j) = CS%Visbeck_L_scale**2*G%areaCu(I,j) + enddo; enddo + do J=js-1,Jeq ; do i=is,ie + CS%L2v(i,J) = CS%Visbeck_L_scale**2*G%areaCv(i,J) + enddo; enddo + else + CS%L2u(:,:) = CS%Visbeck_L_scale**2 + CS%L2v(:,:) = CS%Visbeck_L_scale**2 + endif CS%id_L2u = register_diag_field('ocean_model', 'L2u', diag%axesCu1, Time, & 'Length scale squared for mixing coefficient, at u-points', 'm2') @@ -1067,39 +1087,39 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Resolution function for scaling diffusivities', 'nondim') call get_param(param_file, mdl, "KH_RES_SCALE_COEF", CS%Res_coef_khth, & - "A coefficient that determines how KhTh is scaled away if \n"//& - "RESOLN_SCALED_... is true, as \n"//& + "A coefficient that determines how KhTh is scaled away if "//& + "RESOLN_SCALED_... is true, as "//& "F = 1 / (1 + (KH_RES_SCALE_COEF*Rd/dx)^KH_RES_FN_POWER).", & units="nondim", default=1.0) call get_param(param_file, mdl, "KH_RES_FN_POWER", CS%Res_fn_power_khth, & - "The power of dx/Ld in the Kh resolution function. Any \n"//& - "positive integer may be used, although even integers \n"//& - "are more efficient to calculate. Setting this greater \n"//& + "The power of dx/Ld in the Kh resolution function. Any "//& + "positive integer may be used, although even integers "//& + "are more efficient to calculate. Setting this greater "//& "than 100 results in a step-function being used.", & units="nondim", default=2) call get_param(param_file, mdl, "VISC_RES_SCALE_COEF", CS%Res_coef_visc, & - "A coefficient that determines how Kh is scaled away if \n"//& - "RESOLN_SCALED_... is true, as \n"//& - "F = 1 / (1 + (KH_RES_SCALE_COEF*Rd/dx)^KH_RES_FN_POWER).\n"//& + "A coefficient that determines how Kh is scaled away if "//& + "RESOLN_SCALED_... is true, as "//& + "F = 1 / (1 + (KH_RES_SCALE_COEF*Rd/dx)^KH_RES_FN_POWER). "//& "This function affects lateral viscosity, Kh, and not KhTh.", & units="nondim", default=CS%Res_coef_khth) call get_param(param_file, mdl, "VISC_RES_FN_POWER", CS%Res_fn_power_visc, & - "The power of dx/Ld in the Kh resolution function. Any \n"//& - "positive integer may be used, although even integers \n"//& - "are more efficient to calculate. Setting this greater \n"//& - "than 100 results in a step-function being used.\n"//& + "The power of dx/Ld in the Kh resolution function. Any "//& + "positive integer may be used, although even integers "//& + "are more efficient to calculate. Setting this greater "//& + "than 100 results in a step-function being used. "//& "This function affects lateral viscosity, Kh, and not KhTh.", & units="nondim", default=CS%Res_fn_power_khth) call get_param(param_file, mdl, "INTERPOLATE_RES_FN", CS%interpolate_Res_fn, & - "If true, interpolate the resolution function to the \n"//& - "velocity points from the thickness points; otherwise \n"//& - "interpolate the wave speed and calculate the resolution \n"//& + "If true, interpolate the resolution function to the "//& + "velocity points from the thickness points; otherwise "//& + "interpolate the wave speed and calculate the resolution "//& "function independently at each point.", default=.true.) call get_param(param_file, mdl, "USE_VISBECK_SLOPE_BUG", CS%use_Visbeck_slope_bug, & - "If true, then retain a legacy bug in the calculation of weights \n"//& - "applied to isoneutral slopes. There was an erroneous k-indexing \n"//& - "for layer thicknesses. In addition, masking at coastlines was not \n"//& - "used which introduced potential restart issues. This flag will be \n"//& + "If true, then retain a legacy bug in the calculation of weights "//& + "applied to isoneutral slopes. There was an erroneous k-indexing "//& + "for layer thicknesses. In addition, masking at coastlines was not "//& + "used which introduced potential restart issues. This flag will be "//& "deprecated in a future release.", default=.false.) if (CS%interpolate_Res_fn) then if (CS%Res_coef_visc /= CS%Res_coef_khth) call MOM_error(FATAL, & @@ -1109,12 +1129,13 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.") endif + !### Change the default of GILL_EQUATORIAL_LD to True. call get_param(param_file, mdl, "GILL_EQUATORIAL_LD", Gill_equatorial_Ld, & - "If true, uses Gill's definition of the baroclinic\n"//& - "equatorial deformation radius, otherwise, if false, use\n"//& - "Pedlosky's definition. These definitions differ by a factor\n"//& - "of 2 infront of the beta term in the denominator. Gill's"//& - "is the more appropriate definition.\n", default=.false.) + "If true, uses Gill's definition of the baroclinic "//& + "equatorial deformation radius, otherwise, if false, use "//& + "Pedlosky's definition. These definitions differ by a factor "//& + "of 2 in front of the beta term in the denominator. Gill's "//& + "is the more appropriate definition.", default=.false.) if (Gill_equatorial_Ld) then oneOrTwo = 2.0 endif @@ -1196,10 +1217,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, include the beta term in the Leith nonlinear eddy viscosity.", & default=.true.) - allocate(CS%Laplac3_const_u(IsdB:IedB,jsd:jed)) ; CS%Laplac3_const_u(:,:) = 0.0 - allocate(CS%Laplac3_const_v(isd:ied,JsdB:JedB)) ; CS%Laplac3_const_v(:,:) = 0.0 - allocate(CS%KH_u_QG(IsdB:IedB,jsd:jed,G%ke)) ; CS%KH_u_QG(:,:,:) = 0.0 - allocate(CS%KH_v_QG(isd:ied,JsdB:JedB,G%ke)) ; CS%KH_v_QG(:,:,:) = 0.0 + ALLOC_(CS%Laplac3_const_u(IsdB:IedB,jsd:jed)) ; CS%Laplac3_const_u(:,:) = 0.0 + ALLOC_(CS%Laplac3_const_v(isd:ied,JsdB:JedB)) ; CS%Laplac3_const_v(:,:) = 0.0 + ALLOC_(CS%KH_u_QG(IsdB:IedB,jsd:jed,G%ke)) ; CS%KH_u_QG(:,:,:) = 0.0 + ALLOC_(CS%KH_v_QG(isd:ied,JsdB:JedB,G%ke)) ; CS%KH_v_QG(:,:,:) = 0.0 ! register diagnostics CS%id_KH_u_QG = register_diag_field('ocean_model', 'KH_u_QG', diag%axesCuL, Time, & diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index eef2a2f954..f9db6eba2b 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -7,7 +7,7 @@ module MOM_mixed_layer_restrat use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type use MOM_diag_mediator, only : diag_update_remap_grids -use MOM_domains, only : pass_var +use MOM_domains, only : pass_var, To_West, To_South, Omit_Corners use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing @@ -524,14 +524,14 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) if (CS%id_uml > 0) then - do J=js,je ; do i=is,ie + do J=js,je ; do i=is-1,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (PSI(0.)-PSI(-.01)) enddo ; enddo call post_data(CS%id_uml, uDml_diag, CS%diag) endif if (CS%id_vml > 0) then - do J=js,je ; do i=is,ie + do J=js-1,je ; do i=is,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (PSI(0.)-PSI(-.01)) enddo ; enddo @@ -650,54 +650,50 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! U - Component !$OMP do - do j=js,je - do i=is,ie ; utimescale_diag(i,j) = 0.0 ; enddo - do i=is,ie ; vtimescale_diag(i,j) = 0.0 ; enddo - do I=is-1,ie - h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z - - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) - absf = 0.5*US%s_to_T*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - ! peak ML visc: u_star * 0.41 * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) - ! momentum mixing rate: pi^2*visc/h_ml^2 - ! 0.41 is the von Karmen constant, 9.8696 = pi^2. - mom_mixrate = (0.41*9.8696)*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) - timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) - - timescale = timescale * CS%ml_restrat_coef -! timescale = timescale*(2?)*(L_def/L_MLI)*min(EKE/MKE,1.0 + G%dyCv(i,j)**2/L_def**2)) + do j=js,je; do I=is-1,ie + h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z - utimescale_diag(I,j) = timescale - - uDml(I) = timescale * G%mask2dCu(I,j)*G%dyCu(I,j)* & - G%IdxCu(I,j)*(Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) - - if (uDml(i) == 0) then - do k=1,nkml ; uhml(I,j,k) = 0.0 ; enddo - else - I2htot = 1.0 / (htot(i,j) + htot(i+1,j) + h_neglect) - z_topx2 = 0.0 - ! a(k) relates the sublayer transport to uDml with a linear profile. - ! The sum of a(k) through the mixed layers must be 0. - do k=1,nkml - hx2 = (h(i,j,k) + h(i+1,j,k) + h_neglect) - a(k) = (hx2 * I2htot) * (2.0 - 4.0*(z_topx2+0.5*hx2)*I2htot) - z_topx2 = z_topx2 + hx2 - if (a(k)*uDml(I) > 0.0) then - if (a(k)*uDml(I) > h_avail(i,j,k)) uDml(I) = h_avail(i,j,k) / a(k) - else - if (-a(k)*uDml(I) > h_avail(i+1,j,k)) uDml(I) = -h_avail(i+1,j,k)/a(k) - endif - enddo - do k=1,nkml - uhml(I,j,k) = a(k)*uDml(I) - uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt - enddo - endif - enddo - uDml_diag(is:ie,j) = uDml(is:ie) - enddo + u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) + absf = 0.5*US%s_to_T*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + ! peak ML visc: u_star * 0.41 * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + ! 0.41 is the von Karmen constant, 9.8696 = pi^2. + mom_mixrate = (0.41*9.8696)*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + + timescale = timescale * CS%ml_restrat_coef +! timescale = timescale*(2?)*(L_def/L_MLI)*min(EKE/MKE,1.0 + G%dyCv(i,j)**2/L_def**2)) + + uDml(I) = timescale * G%mask2dCu(I,j)*G%dyCu(I,j)* & + G%IdxCu(I,j)*(Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) + + if (uDml(I) == 0) then + do k=1,nkml ; uhml(I,j,k) = 0.0 ; enddo + else + I2htot = 1.0 / (htot(i,j) + htot(i+1,j) + h_neglect) + z_topx2 = 0.0 + ! a(k) relates the sublayer transport to uDml with a linear profile. + ! The sum of a(k) through the mixed layers must be 0. + do k=1,nkml + hx2 = (h(i,j,k) + h(i+1,j,k) + h_neglect) + a(k) = (hx2 * I2htot) * (2.0 - 4.0*(z_topx2+0.5*hx2)*I2htot) + z_topx2 = z_topx2 + hx2 + if (a(k)*uDml(I) > 0.0) then + if (a(k)*uDml(I) > h_avail(i,j,k)) uDml(I) = h_avail(i,j,k) / a(k) + else + if (-a(k)*uDml(I) > h_avail(i+1,j,k)) uDml(I) = -h_avail(i+1,j,k)/a(k) + endif + enddo + do k=1,nkml + uhml(I,j,k) = a(k)*uDml(I) + uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt + enddo + endif + + uDml_diag(I,j) = uDml(I) + utimescale_diag(I,j) = timescale + enddo; enddo ! V- component !$OMP do @@ -716,8 +712,6 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI)*min(EKE/MKE,1.0 + G%dyCv(i,j)**2/L_def**2)) - vtimescale_diag(i,J) = timescale - vDml(i) = timescale * G%mask2dCv(i,J)*G%dxCv(i,J)* & G%IdyCv(i,J)*(Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) if (vDml(i) == 0) then @@ -742,9 +736,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k)*dt enddo endif - enddo - vDml_diag(is:ie,j) = vDml(is:ie) - enddo + + vtimescale_diag(i,J) = timescale + vDml_diag(i,J) = vDml(i) + enddo; enddo !$OMP do do j=js,je ; do k=1,nkml ; do i=is,ie @@ -755,6 +750,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! Whenever thickness changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. + if (CS%id_uhml > 0 .or. CS%id_vhml > 0) & + ! Remapped uhml and vhml require east/north halo updates of h + call pass_var(h, G%domain, To_West+To_South+Omit_Corners, halo=1) call diag_update_remap_grids(CS%diag) ! Offer diagnostic fields for averaging. @@ -802,9 +800,9 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & - "If true, a density-gradient dependent re-stratifying \n"//& - "flow is imposed in the mixed layer. Can be used in ALE mode\n"//& - "without restriction but in layer mode can only be used if\n"//& + "If true, a density-gradient dependent re-stratifying "//& + "flow is imposed in the mixed layer. Can be used in ALE mode "//& + "without restriction but in layer mode can only be used if "//& "BULKMIXEDLAYER is true.", default=.false.) if (.not. mixedlayer_restrat_init) return @@ -822,53 +820,53 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF", CS%ml_restrat_coef, & - "A nondimensional coefficient that is proportional to \n"//& - "the ratio of the deformation radius to the dominant \n"//& - "lengthscale of the submesoscale mixed layer \n"//& - "instabilities, times the minimum of the ratio of the \n"//& - "mesoscale eddy kinetic energy to the large-scale \n"//& - "geostrophic kinetic energy or 1 plus the square of the \n"//& - "grid spacing over the deformation radius, as detailed \n"//& + "A nondimensional coefficient that is proportional to "//& + "the ratio of the deformation radius to the dominant "//& + "lengthscale of the submesoscale mixed layer "//& + "instabilities, times the minimum of the ratio of the "//& + "mesoscale eddy kinetic energy to the large-scale "//& + "geostrophic kinetic energy or 1 plus the square of the "//& + "grid spacing over the deformation radius, as detailed "//& "by Fox-Kemper et al. (2010)", units="nondim", default=0.0) ! We use GV%nkml to distinguish between the old and new implementation of MLE. ! The old implementation only works for the layer model with nkml>0. if (GV%nkml==0) then call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF2", CS%ml_restrat_coef2, & - "As for FOX_KEMPER_ML_RESTRAT_COEF but used in a second application\n"//& + "As for FOX_KEMPER_ML_RESTRAT_COEF but used in a second application "//& "of the MLE restratification parameterization.", units="nondim", default=0.0) call get_param(param_file, mdl, "MLE_FRONT_LENGTH", CS%front_length, & - "If non-zero, is the frontal-length scale used to calculate the\n"//& - "upscaling of buoyancy gradients that is otherwise represented\n"//& - "by the parameter FOX_KEMPER_ML_RESTRAT_COEF. If MLE_FRONT_LENGTH is\n"//& + "If non-zero, is the frontal-length scale used to calculate the "//& + "upscaling of buoyancy gradients that is otherwise represented "//& + "by the parameter FOX_KEMPER_ML_RESTRAT_COEF. If MLE_FRONT_LENGTH is "//& "non-zero, it is recommended to set FOX_KEMPER_ML_RESTRAT_COEF=1.0.",& units="m", default=0.0) call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & - "If true, the MLE parameterization will use the mixed-layer\n"//& - "depth provided by the active PBL parameterization. If false,\n"//& - "MLE will estimate a MLD based on a density difference with the\n"//& + "If true, the MLE parameterization will use the mixed-layer "//& + "depth provided by the active PBL parameterization. If false, "//& + "MLE will estimate a MLD based on a density difference with the "//& "surface using the parameter MLE_DENSITY_DIFF.", default=.false.) call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & - "The time-scale for a running-mean filter applied to the mixed-layer\n"//& - "depth used in the MLE restratification parameterization. When\n"//& - "the MLD deepens below the current running-mean the running-mean\n"//& + "The time-scale for a running-mean filter applied to the mixed-layer "//& + "depth used in the MLE restratification parameterization. When "//& + "the MLD deepens below the current running-mean the running-mean "//& "is instantaneously set to the current MLD.", units="s", default=0.) call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & - "The time-scale for a running-mean filter applied to the filtered\n"//& - "mixed-layer depth used in a second MLE restratification parameterization.\n"//& - "When the MLD deepens below the current running-mean the running-mean\n"//& + "The time-scale for a running-mean filter applied to the filtered "//& + "mixed-layer depth used in a second MLE restratification parameterization. "//& + "When the MLD deepens below the current running-mean the running-mean "//& "is instantaneously set to the current MLD.", units="s", default=0.) if (.not. CS%MLE_use_PBL_MLD) then call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & - "Density difference used to detect the mixed-layer\n"//& - "depth used for the mixed-layer eddy parameterization\n"//& + "Density difference used to detect the mixed-layer "//& + "depth used for the mixed-layer eddy parameterization "//& "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03) endif call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & - "Fraction by which to extend the mixed-layer restratification\n"//& - "depth used for a smoother stream function at the base of\n"//& + "Fraction by which to extend the mixed-layer restratification "//& + "depth used for a smoother stream function at the base of "//& "the mixed-layer.", units="nondim", default=0.0) call get_param(param_file, mdl, "MLE_MLD_STRETCH", CS%MLE_MLD_stretch, & - "A scaling coefficient for stretching/shrinking the MLD\n"//& + "A scaling coefficient for stretching/shrinking the MLD "//& "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) call get_param(param_file, mdl, "MLE_USE_MLD_AVE_BUG", CS%MLE_use_MLD_ave_bug, & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 68b747182d..3ebf159e3d 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -137,8 +137,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real :: Khth_Loc_u(SZIB_(G), SZJ_(G)) real :: Khth_Loc(SZIB_(G), SZJB_(G)) ! locally calculated thickness diffusivity [m2 s-1] real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real, dimension(:,:), pointer :: cg1 => null() !< Wave speed (m/s) + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real, dimension(:,:), pointer :: cg1 => null() !< Wave speed [m s-1] logical :: use_VarMix, Resoln_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck logical :: use_QG_Leith integer :: i, j, k, is, ie, js, je, nz @@ -215,7 +215,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp !$OMP do if (CS%MEKE_GEOMETRIC) then do j=js,je ; do I=is-1,ie - Khth_Loc_u(I,j) = Khth_Loc_u(I,j) + G%mask2dCu(I,j) * CS%MEKE_GEOMETRIC_alpha * 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i+1,j)) / & + Khth_Loc_u(I,j) = Khth_Loc_u(I,j) + & + G%mask2dCu(I,j) * CS%MEKE_GEOMETRIC_alpha * 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i+1,j)) / & (VarMix%SN_u(I,j) + CS%MEKE_GEOMETRIC_epsilon) enddo ; enddo else @@ -293,8 +294,9 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp !$OMP do if (CS%MEKE_GEOMETRIC) then do j=js-1,je ; do I=is,ie - Khth_Loc(I,j) = Khth_Loc(I,j) + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i,j+1)) / & - (VarMix%SN_v(i,J) + CS%MEKE_GEOMETRIC_epsilon) + Khth_Loc(I,j) = Khth_Loc(I,j) + & + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i,j+1)) / & + (VarMix%SN_v(i,J) + CS%MEKE_GEOMETRIC_epsilon) enddo ; enddo else do J=js-1,je ; do i=is,ie @@ -525,12 +527,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV type(MEKE_type), pointer :: MEKE !< MEKE control structure type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), optional, intent(in) :: int_slope_u !< Ratio that determine how much of - !! the isopycnal slopes are taken directly from the - !! interface slopes without consideration of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration of !! density gradients. real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), optional, intent(in) :: int_slope_v !< Ratio that determine how much of - !! the isopycnal slopes are taken directly from the - !! interface slopes without consideration of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration of !! density gradients. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), optional, intent(in) :: slope_x !< Isopycnal slope at u-points real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), optional, intent(in) :: slope_y !< Isopycnal slope at v-points @@ -545,14 +547,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_avail, & ! The mass available for diffusion out of each face, divided ! by dt [H m2 s-1 ~> m3 s-1 or kg s-1]. h_frac ! The fraction of the mass in the column above the bottom - ! interface of a layer that is within a layer, ND. 0 m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_in !< Input temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_in !< Input salinity [ppt] - real, intent(in) :: kappa !< Constant diffusivity to use [Z2 s-1 ~> m2 s-1] - real, intent(in) :: dt !< Time increment [s] + real, intent(in) :: kappa !< Constant diffusivity to use [Z2 T-1 ~> m2 s-1] + real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T_f !< Filled temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S_f !< Filled salinity [ppt] integer, optional, intent(in) :: halo_here !< Number of halo points to work on, @@ -1848,13 +1850,13 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "THICKNESSDIFFUSE", CS%thickness_diffuse, & - "If true, interface heights are diffused with a \n"//& + "If true, interface heights are diffused with a "//& "coefficient of KHTH.", default=.false.) call get_param(param_file, mdl, "KHTH", CS%Khth, & "The background horizontal thickness diffusivity.", & units = "m2 s-1", default=0.0) call get_param(param_file, mdl, "KHTH_SLOPE_CFF", CS%KHTH_Slope_Cff, & - "The nondimensional coefficient in the Visbeck formula \n"//& + "The nondimensional coefficient in the Visbeck formula "//& "for the interface depth diffusivity", units="nondim", & default=0.0) call get_param(param_file, mdl, "KHTH_MIN", CS%KHTH_Min, & @@ -1864,10 +1866,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "The maximum horizontal thickness diffusivity.", & units = "m2 s-1", default=0.0) call get_param(param_file, mdl, "KHTH_MAX_CFL", CS%max_Khth_CFL, & - "The maximum value of the local diffusive CFL ratio that \n"//& - "is permitted for the thickness diffusivity. 1.0 is the \n"//& - "marginally unstable value in a pure layered model, but \n"//& - "much smaller numbers (e.g. 0.1) seem to work better for \n"//& + "The maximum value of the local diffusive CFL ratio that "//& + "is permitted for the thickness diffusivity. 1.0 is the "//& + "marginally unstable value in a pure layered model, but "//& + "much smaller numbers (e.g. 0.1) seem to work better for "//& "ALE-based models.", units = "nondimensional", default=0.8) ! call get_param(param_file, mdl, "USE_QG_LEITH_GM", CS%QG_Leith_GM, & @@ -1876,38 +1878,38 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) if (CS%max_Khth_CFL < 0.0) CS%max_Khth_CFL = 0.0 call get_param(param_file, mdl, "DETANGLE_INTERFACES", CS%detangle_interfaces, & - "If defined add 3-d structured enhanced interface height \n"//& - "diffusivities to horizonally smooth jagged layers.", & + "If defined add 3-d structured enhanced interface height "//& + "diffusivities to horizontally smooth jagged layers.", & default=.false.) CS%detangle_time = 0.0 if (CS%detangle_interfaces) & call get_param(param_file, mdl, "DETANGLE_TIMESCALE", CS%detangle_time, & - "A timescale over which maximally jagged grid-scale \n"//& - "thickness variations are suppressed. This must be \n"//& + "A timescale over which maximally jagged grid-scale "//& + "thickness variations are suppressed. This must be "//& "longer than DT, or 0 to use DT.", units = "s", default=0.0) call get_param(param_file, mdl, "KHTH_SLOPE_MAX", CS%slope_max, & - "A slope beyond which the calculated isopycnal slope is \n"//& + "A slope beyond which the calculated isopycnal slope is "//& "not reliable and is scaled away.", units="nondim", default=0.01) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & - "A diapycnal diffusivity that is used to interpolate \n"//& + "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & default=1.0e-6, scale=US%m_to_Z**2) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", CS%use_FGNV_streamfn, & - "If true, use the streamfunction formulation of\n"// & - "Ferrari et al., 2010, which effectively emphasizes\n"//& + "If true, use the streamfunction formulation of "//& + "Ferrari et al., 2010, which effectively emphasizes "//& "graver vertical modes by smoothing in the vertical.", & default=.false.) call get_param(param_file, mdl, "FGNV_FILTER_SCALE", CS%FGNV_scale, & - "A coefficient scaling the vertical smoothing term in the\n"//& + "A coefficient scaling the vertical smoothing term in the "//& "Ferrari et al., 2010, streamfunction formulation.", & default=1., do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "FGNV_C_MIN", CS%FGNV_c_min, & - "A minium wave speed used in the Ferrari et al., 2010,\n"//& + "A minium wave speed used in the Ferrari et al., 2010, "//& "streamfunction formulation.", & default=0., units="m s-1", do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "FGNV_STRAT_FLOOR", strat_floor, & - "A floor for Brunt-Vaisala frequency in the Ferrari et al., 2010,\n"//& - "streamfunction formulation, expressed as a fraction of planetary\n"//& + "A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, "//& + "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "OMEGA",omega, & @@ -2010,9 +2012,9 @@ subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G) !! this module type(ocean_grid_type), intent(in) :: G !< Grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: KH_u_GME!< interface height - !! diffusivities in u-columns (m2 s-1) + !! diffusivities in u-columns [m2 s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: KH_v_GME!< interface height - !! diffusivities in v-columns (m2 s-1) + !! diffusivities in v-columns [m2 s-1] ! Local variables integer :: i,j,k diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 075c69ed65..57a1d78c03 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -123,43 +123,43 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) enddo ; enddo call get_param(param_file, mdl, "TIDE_M2", use_M2, & - "If true, apply tidal momentum forcing at the M2 \n"//& + "If true, apply tidal momentum forcing at the M2 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_S2", use_S2, & - "If true, apply tidal momentum forcing at the S2 \n"//& + "If true, apply tidal momentum forcing at the S2 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_N2", use_N2, & - "If true, apply tidal momentum forcing at the N2 \n"//& + "If true, apply tidal momentum forcing at the N2 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_K2", use_K2, & - "If true, apply tidal momentum forcing at the K2 \n"//& + "If true, apply tidal momentum forcing at the K2 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_K1", use_K1, & - "If true, apply tidal momentum forcing at the K1 \n"//& + "If true, apply tidal momentum forcing at the K1 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_O1", use_O1, & - "If true, apply tidal momentum forcing at the O1 \n"//& + "If true, apply tidal momentum forcing at the O1 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_P1", use_P1, & - "If true, apply tidal momentum forcing at the P1 \n"//& + "If true, apply tidal momentum forcing at the P1 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_Q1", use_Q1, & - "If true, apply tidal momentum forcing at the Q1 \n"//& + "If true, apply tidal momentum forcing at the Q1 "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_MF", use_MF, & - "If true, apply tidal momentum forcing at the MF \n"//& + "If true, apply tidal momentum forcing at the MF "//& "frequency. This is only used if TIDES is true.", & default=.false.) call get_param(param_file, mdl, "TIDE_MM", use_MM, & - "If true, apply tidal momentum forcing at the MM \n"//& + "If true, apply tidal momentum forcing at the MM "//& "frequency. This is only used if TIDES is true.", & default=.false.) @@ -179,29 +179,29 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) endif call get_param(param_file, mdl, "TIDAL_SAL_FROM_FILE", CS%tidal_sal_from_file, & - "If true, read the tidal self-attraction and loading \n"//& - "from input files, specified by TIDAL_INPUT_FILE. \n"//& + "If true, read the tidal self-attraction and loading "//& + "from input files, specified by TIDAL_INPUT_FILE. "//& "This is only used if TIDES is true.", default=.false.) call get_param(param_file, mdl, "USE_PREVIOUS_TIDES", CS%use_prev_tides, & - "If true, use the SAL from the previous iteration of the \n"//& - "tides to facilitate convergent iteration. \n"//& + "If true, use the SAL from the previous iteration of the "//& + "tides to facilitate convergent iteration. "//& "This is only used if TIDES is true.", default=.false.) call get_param(param_file, mdl, "TIDE_USE_SAL_SCALAR", CS%use_sal_scalar, & - "If true and TIDES is true, use the scalar approximation \n"//& + "If true and TIDES is true, use the scalar approximation "//& "when calculating self-attraction and loading.", & default=.not.CS%tidal_sal_from_file) ! If it is being used, sal_scalar MUST be specified in param_file. if (CS%use_sal_scalar .or. CS%use_prev_tides) & call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & - "The constant of proportionality between sea surface \n"//& - "height (really it should be bottom pressure) anomalies \n"//& - "and bottom geopotential anomalies. This is only used if \n"//& + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & fail_if_missing=.true.) if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & - &"to accomodate all the registered tidal constituents.")') nc + &"to accommodate all the registered tidal constituents.")') nc call MOM_error(FATAL, "MOM_tidal_forcing"//mesg) endif @@ -290,15 +290,15 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) ! values that are actually used. do c=1,nc call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_FREQ", CS%freq(c), & - "Frequency of the "//trim(CS%const_name(c))//" tidal constituent. \n"//& + "Frequency of the "//trim(CS%const_name(c))//" tidal constituent. "//& "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & " are true.", units="s-1", default=freq_def(c)) call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_AMP", CS%amp(c), & - "Amplitude of the "//trim(CS%const_name(c))//" tidal constituent. \n"//& + "Amplitude of the "//trim(CS%const_name(c))//" tidal constituent. "//& "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & " are true.", units="m", default=amp_def(c)) call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_PHASE_T0", CS%phase0(c), & - "Phase of the "//trim(CS%const_name(c))//" tidal constituent at time 0. \n"//& + "Phase of the "//trim(CS%const_name(c))//" tidal constituent at time 0. "//& "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & " are true.", units="radians", default=phase0_def(c)) enddo diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 7678a4b799..0cc63a8fc0 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -170,8 +170,8 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SPONGE", use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) if (.not.use_sponge) return @@ -183,14 +183,14 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ default=.false.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used \n"//& + "This sets the reconstruction scheme used "//& " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction \n"//& - "scheme is used within boundary cells rather \n"// & - "than PCM. E.g., if PPM is used for remapping, a \n" //& + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) @@ -401,8 +401,8 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SPONGE", use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) if (.not.use_sponge) return @@ -414,14 +414,14 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) default=.false.) call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & - "This sets the reconstruction scheme used \n"//& + "This sets the reconstruction scheme used "//& " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & - "When defined, a proper high-order reconstruction \n"//& - "scheme is used within boundary cells rather \n"// & - "than PCM. E.g., if PPM is used for remapping, a \n" //& + "When defined, a proper high-order reconstruction "//& + "scheme is used within boundary cells rather "//& + "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 139754cada..f281a7b927 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -147,6 +147,7 @@ module MOM_CVMix_KPP real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL [m] without smoothing real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [m] + real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [kg m-3] real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [m2 s-2] real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer (dimensionless) @@ -201,7 +202,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) call log_version(paramFile, mdl, version, 'This is the MOM wrapper to CVMix:KPP\n' // & 'See http://cvmix.github.io/') call get_param(paramFile, mdl, "USE_KPP", KPP_init, & - "If true, turns on the [CVMix] KPP scheme of Large et al., 1994,\n"// & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "// & "to calculate diffusivities and non-local transport in the OBL.", & default=.false.) ! Forego remainder of initialization if not using this scheme @@ -216,22 +217,22 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) if (present(passive)) passive=CS%passiveMode ! This is passed back to the caller so ! the caller knows to not use KPP output call get_param(paramFile, mdl, 'APPLY_NONLOCAL_TRANSPORT', CS%applyNonLocalTrans, & - 'If True, applies the non-local transport to heat and scalars.\n'// & - 'If False, calculates the non-local transport and tendencies but\n'//& + 'If True, applies the non-local transport to heat and scalars. '// & + 'If False, calculates the non-local transport and tendencies but '//& 'purely for diagnostic purposes.', & default=.not. CS%passiveMode) call get_param(paramFile, mdl, 'N_SMOOTH', CS%n_smooth, & - 'The number of times the 1-1-4-1-1 Laplacian filter is applied on\n'// & + 'The number of times the 1-1-4-1-1 Laplacian filter is applied on '// & 'OBL depth.', & default=0) if (CS%n_smooth > 0) then call get_param(paramFile, mdl, 'DEEPEN_ONLY_VIA_SMOOTHING', CS%deepen_only, & - 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth.\n'// & + 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth '// & 'gets deeper via smoothing.', & default=.false.) endif call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & - 'Critical bulk Richardson number used to define depth of the\n'// & + 'Critical bulk Richardson number used to define depth of the '// & 'surface Ocean Boundary Layer (OBL).', & units='nondim', default=0.3) call get_param(paramFile, mdl, 'VON_KARMAN', CS%vonKarman, & @@ -252,7 +253,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'If True, limit OBL depth to be no deeper than Ekman depth.', & default=.False.) call get_param(paramFile, mdl, 'COMPUTE_MONIN_OBUKHOV', CS%computeMoninObukhov, & - 'If True, limit the OBL depth to be no deeper than\n'// & + 'If True, limit the OBL depth to be no deeper than '// & 'Monin-Obukhov depth.', & default=.False.) call get_param(paramFile, mdl, 'CS', CS%cs, & @@ -262,47 +263,47 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'Parameter for computing non-local term.', & units='nondim', default=6.32739901508) call get_param(paramFile, mdl, 'DEEP_OBL_OFFSET', CS%deepOBLoffset, & - 'If non-zero, the distance above the bottom to which the OBL is clipped\n'// & + 'If non-zero, the distance above the bottom to which the OBL is clipped '// & 'if it would otherwise reach the bottom. The smaller of this and 0.1D is used.', & units='m',default=0.) call get_param(paramFile, mdl, 'FIXED_OBLDEPTH', CS%fixedOBLdepth, & - 'If True, fix the OBL depth to FIXED_OBLDEPTH_VALUE\n'// & - 'rather than using the OBL depth from CVMix.\n'// & + 'If True, fix the OBL depth to FIXED_OBLDEPTH_VALUE '// & + 'rather than using the OBL depth from CVMix. '// & 'This option is just for testing purposes.', & default=.False.) call get_param(paramFile, mdl, 'FIXED_OBLDEPTH_VALUE', CS%fixedOBLdepth_value, & - 'Value for the fixed OBL depth when fixedOBLdepth==True. \n'// & - 'This parameter is for just for testing purposes. \n'// & + 'Value for the fixed OBL depth when fixedOBLdepth==True. '// & + 'This parameter is for just for testing purposes. '// & 'It will over-ride the OBLdepth computed from CVMix.', & units='m',default=30.0) call get_param(paramFile, mdl, 'SURF_LAYER_EXTENT', CS%surf_layer_ext, & 'Fraction of OBL depth considered in the surface layer.', & units='nondim',default=0.10) call get_param(paramFile, mdl, 'MINIMUM_OBL_DEPTH', CS%minOBLdepth, & - 'If non-zero, a minimum depth to use for KPP OBL depth. Independent of\n'// & + 'If non-zero, a minimum depth to use for KPP OBL depth. Independent of '// & 'this parameter, the OBL depth is always at least as deep as the first layer.', & units='m',default=0.) call get_param(paramFile, mdl, 'MINIMUM_VT2', CS%minVtsqr, & - 'Min of the unresolved velocity Vt2 used in Rib CVMix calculation. \n'// & + 'Min of the unresolved velocity Vt2 used in Rib CVMix calculation.\n'// & 'Scaling: MINIMUM_VT2 = const1*d*N*ws, with d=1m, N=1e-5/s, ws=1e-6 m/s.', & units='m2/s2',default=1e-10) ! smg: for removal below call get_param(paramFile, mdl, 'CORRECT_SURFACE_LAYER_AVERAGE', CS%correctSurfLayerAvg, & - 'If true, applies a correction step to the averaging of surface layer\n'// & + 'If true, applies a correction step to the averaging of surface layer '// & 'properties. This option is obsolete.', default=.False.) if (CS%correctSurfLayerAvg) & call MOM_error(FATAL,'Correct surface layer average disabled in code. To recover \n'// & ' feature will require code intervention.') call get_param(paramFile, mdl, 'FIRST_GUESS_SURFACE_LAYER_DEPTH', CS%surfLayerDepth, & - 'The first guess at the depth of the surface layer used for averaging\n'// & - 'the surface layer properties. If =0, the top model level properties\n'// & - 'will be used for the surface layer. If CORRECT_SURFACE_LAYER_AVERAGE=True, a\n'// & + 'The first guess at the depth of the surface layer used for averaging '// & + 'the surface layer properties. If =0, the top model level properties '// & + 'will be used for the surface layer. If CORRECT_SURFACE_LAYER_AVERAGE=True, a '// & 'subsequent correction is applied. This parameter is obsolete', units='m', default=0.) ! smg: for removal above call get_param(paramFile, mdl, 'NLT_SHAPE', string, & - 'MOM6 method to set nonlocal transport profile.\n'// & + 'MOM6 method to set nonlocal transport profile. '// & 'Over-rides the result from CVMix. Allowed values are: \n'// & '\t CVMix - Uses the profiles from CVMix specified by MATCH_TECHNIQUE\n'//& '\t LINEAR - A linear profile, 1-sigma\n'// & @@ -320,7 +321,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) "Unrecognized NLT_SHAPE option"//trim(string)) end select call get_param(paramFile, mdl, 'MATCH_TECHNIQUE', CS%MatchTechnique, & - 'CVMix method to set profile function for diffusivity and NLT,\n'// & + 'CVMix method to set profile function for diffusivity and NLT, '// & 'as well as matching across OBL base. Allowed values are: \n'// & '\t SimpleShapes = sigma*(1-sigma)^2 for both diffusivity and NLT\n'// & '\t MatchGradient = sigma*(1-sigma)^2 for NLT; diffusivity profile from matching\n'//& @@ -328,19 +329,19 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) '\t ParabolicNonLocal = sigma*(1-sigma)^2 for diffusivity; (1-sigma)^2 for NLT', & default='SimpleShapes') if (CS%MatchTechnique == 'ParabolicNonLocal') then - ! This forces Cs2 (Cs in non-local computation) to equal 1 for parabolic non-local option. - ! May be used during CVMix initialization. - Cs_is_one=.true. + ! This forces Cs2 (Cs in non-local computation) to equal 1 for parabolic non-local option. + ! May be used during CVMix initialization. + Cs_is_one=.true. endif if (CS%MatchTechnique == 'ParabolicNonLocal' .or. CS%MatchTechnique == 'SimpleShapes') then - ! if gradient won't be matched, lnoDGat1=.true. - lnoDGat1=.true. + ! if gradient won't be matched, lnoDGat1=.true. + lnoDGat1=.true. endif ! safety check to avoid negative diff/visc if (CS%MatchTechnique == 'MatchBoth' .and. (CS%interpType2 == 'cubic' .or. & - CS%interpType2 == 'quadratic')) then - call MOM_error(FATAL,"If MATCH_TECHNIQUE=MatchBoth, INTERP_TYPE2 must be set to \n"//& + CS%interpType2 == 'quadratic')) then + call MOM_error(FATAL,"If MATCH_TECHNIQUE=MatchBoth, INTERP_TYPE2 must be set to \n"//& "linear or LMD94 (recommended) to avoid negative viscosity and diffusivity.\n"//& "Please select one of these valid options." ) endif @@ -349,15 +350,15 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'If True, zeroes the KPP diffusivity and viscosity; for testing purpose.',& default=.False.) call get_param(paramFile, mdl, 'KPP_IS_ADDITIVE', CS%KPPisAdditive, & - 'If true, adds KPP diffusivity to diffusivity from other schemes.'//& + 'If true, adds KPP diffusivity to diffusivity from other schemes.\n'//& 'If false, KPP is the only diffusivity wherever KPP is non-zero.', & default=.True.) call get_param(paramFile, mdl, 'KPP_SHORTWAVE_METHOD',string, & 'Determines contribution of shortwave radiation to KPP surface '// & 'buoyancy flux. Options include:\n'// & ' ALL_SW: use total shortwave radiation\n'// & - ' MXL_SW: use shortwave radiation absorbed by mixing layer\n'// & - ' LV1_SW: use shortwave radiation absorbed by top model layer', & + ' MXL_SW: use shortwave radiation absorbed by mixing layer\n'// & + ' LV1_SW: use shortwave radiation absorbed by top model layer', & default='MXL_SW') select case ( trim(string) ) case ("ALL_SW") ; CS%SW_METHOD = SW_METHOD_ALL_SW @@ -367,7 +368,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) "Unrecognized KPP_SHORTWAVE_METHOD option"//trim(string)) end select call get_param(paramFile, mdl, 'CVMix_ZERO_H_WORK_AROUND', CS%min_thickness, & - 'A minimum thickness used to avoid division by small numbers in the vicinity\n'// & + 'A minimum thickness used to avoid division by small numbers in the vicinity '// & 'of vanished layers. This is independent of MIN_THICKNESS used in other parts of MOM.', & units='m', default=0.) @@ -381,7 +382,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'mixing coefficient.', units="", Default=.false.) if (CS%LT_K_Enhancement) then call get_param(paramFile, mdl, 'KPP_LT_K_SHAPE', string, & - 'Vertical dependence of LT enhancement of mixing. \n'// & + 'Vertical dependence of LT enhancement of mixing. '// & 'Valid options are: \n'// & '\t CONSTANT = Constant value for full OBL\n'// & '\t SCALED = Varies based on normalized shape function.', & @@ -393,7 +394,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) "Unrecognized KPP_LT_K_SHAPE option: "//trim(string)) end select call get_param(paramFile, mdl, "KPP_LT_K_METHOD", string , & - 'Method to enhance mixing coefficient in KPP. \n'// & + 'Method to enhance mixing coefficient in KPP. '// & 'Valid options are: \n'// & '\t CONSTANT = Constant value (KPP_K_ENH_FAC) \n'// & '\t VR12 = Function of Langmuir number based on VR12\n'// & @@ -418,7 +419,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'in Bulk Richardson Number.', units="", Default=.false.) if (CS%LT_Vt2_Enhancement) then call get_param(paramFile, mdl, "KPP_LT_VT2_METHOD",string , & - 'Method to enhance Vt2 in KPP. \n'// & + 'Method to enhance Vt2 in KPP. '// & 'Valid options are: \n'// & '\t CONSTANT = Constant value (KPP_VT2_ENH_FAC) \n'// & '\t VR12 = Function of Langmuir number based on VR12\n'// & @@ -536,6 +537,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) CS%OBLdepth(:,:) = 0. allocate( CS%kOBL( SZI_(G), SZJ_(G) ) ) CS%kOBL(:,:) = 0. + allocate( CS%La_SL( SZI_(G), SZJ_(G) ) ) + CS%La_SL(:,:) = 0. allocate( CS%Vt2( SZI_(G), SZJ_(G), SZK_(G) ) ) CS%Vt2(:,:,:) = 0. if (CS%id_OBLdepth_original > 0) allocate( CS%OBLdepth_original( SZI_(G), SZJ_(G) ) ) @@ -578,7 +581,7 @@ end function KPP_init !> KPP vertical diffusivity/viscosity and non-local tracer transport subroutine KPP_calculate(CS, G, GV, US, h, uStar, & buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& - nonLocalTransScalar, Waves) + nonLocalTransScalar, waves) ! Arguments type(KPP_CS), pointer :: CS !< Control structure @@ -718,11 +721,11 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & LangEnhK = CS%KPP_K_ENH_FAC elseif (CS%LT_K_METHOD==LT_K_MODE_VR12) then ! Added minimum value for La_SL, so removed maximum value for LangEnhK. - LangEnhK = sqrt(1.+(1.5*WAVES%La_SL(i,j))**(-2) + & - (5.4*WAVES%La_SL(i,j))**(-4)) + LangEnhK = sqrt(1.+(1.5*CS%La_SL(i,j))**(-2) + & + (5.4*CS%La_SL(i,j))**(-4)) elseif (CS%LT_K_METHOD==LT_K_MODE_RW16) then !This maximum value is proposed in Reichl et al., 2016 JPO formula - LangEnhK = min(2.25, 1. + 1./WAVES%La_SL(i,j)) + LangEnhK = min(2.25, 1. + 1./CS%La_SL(i,j)) else !This shouldn't be reached. !call MOM_error(WARNING,"Unexpected behavior in MOM_CVMix_KPP, see error in LT_K_ENHANCEMENT") @@ -1069,15 +1072,10 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF enddo ! k-loop finishes if (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) then - if (.not.(present(WAVES).and.associated(WAVES))) then - call MOM_error(FATAL,"Trying to use input WAVES information in KPP\n"//& - "without activating USEWAVES") - endif - !For now get Langmuir number based on prev. MLD (otherwise must compute 3d LA) MLD_GUESS = max( 1.*US%m_to_Z, abs(US%m_to_Z*CS%OBLdepthprev(i,j) ) ) - call get_Langmuir_Number( LA, G, GV, US, MLD_guess, uStar(i,j), i, j, & + call get_Langmuir_Number( LA, G, GV, US, MLD_guess, surfFricVel, i, j, & H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) - WAVES%La_SL(i,j)=LA + CS%La_SL(i,j)=LA endif @@ -1125,14 +1123,14 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF enddo elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_VR12) then !Introduced minimum value for La_SL, so maximum value for enhvt2 is removed. - enhvt2 = sqrt(1.+(1.5*WAVES%La_SL(i,j))**(-2) + & - (5.4*WAVES%La_SL(i,j))**(-4)) + enhvt2 = sqrt(1.+(1.5*CS%La_SL(i,j))**(-2) + & + (5.4*CS%La_SL(i,j))**(-4)) do k=1,G%ke LangEnhVT2(k) = enhvt2 enddo elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_RW16) then !Introduced minimum value for La_SL, so maximum value for enhvt2 is removed. - enhvt2 = 1. + 2.3*WAVES%La_SL(i,j)**(-0.5) + enhvt2 = 1. + 2.3*CS%La_SL(i,j)**(-0.5) do k=1,G%ke LangEnhVT2(k) = enhvt2 enddo @@ -1141,7 +1139,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF do k=1,G%ke WST = (max(0.,-buoyflux(i,j,1))*(-cellHeight(k)))**(1./3.) LangEnhVT2(k) = sqrt((0.15*WST**3. + 0.17*surfFricVel**3.* & - (1.+0.49*WAVES%La_SL(i,j)**(-2.))) / & + (1.+0.49*CS%La_SL(i,j)**(-2.))) / & (0.2*ws_1d(k)**3/(CS%cs*CS%surf_layer_ext*CS%vonKarman**4.))) enddo else @@ -1314,11 +1312,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF if (CS%id_BulkUz2 > 0) call post_data(CS%id_BulkUz2, CS%Uz2, CS%diag) if (CS%id_EnhK > 0) call post_data(CS%id_EnhK, CS%EnhK, CS%diag) if (CS%id_EnhVt2 > 0) call post_data(CS%id_EnhVt2, CS%EnhVt2, CS%diag) - if (present(WAVES)) then - if ((CS%id_La_SL>0) .and. associated(WAVES)) then - call post_data(CS%id_La_SL,WAVES%La_SL,CS%diag) - endif - endif + if (CS%id_La_SL > 0) call post_data(CS%id_La_SL, CS%La_SL, CS%diag) ! BLD smoothing: if (CS%n_smooth > 0) call KPP_smooth_BLD(CS,G,GV,h) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 19327cd007..1a9cb890ef 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -79,9 +79,9 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, & "Parameterization of enhanced mixing due to convection via CVMix") call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, & - "If true, turns on the enhanced mixing due to convection \n"// & - "via CVMix. This scheme increases diapycnal diffs./viscs. \n"// & - " at statically unstable interfaces. Relevant parameters are \n"// & + "If true, turns on the enhanced mixing due to convection "//& + "via CVMix. This scheme increases diapycnal diffs./viscs. "//& + "at statically unstable interfaces. Relevant parameters are "//& "contained in the CVMix_CONVECTION% parameter block.", & default=.false.) @@ -105,17 +105,17 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) call openParameterBlock(param_file,'CVMix_CONVECTION') call get_param(param_file, mdl, "PRANDTL_CONV", prandtl_conv, & - "The turbulent Prandtl number applied to convective \n"//& + "The turbulent Prandtl number applied to convective "//& "instabilities (i.e., used to convert KD_CONV into KV_CONV)", & units="nondim", default=1.0) call get_param(param_file, mdl, 'KD_CONV', CS%kd_conv_const, & - "Diffusivity used in convective regime. Corresponding viscosity \n" // & + "Diffusivity used in convective regime. Corresponding viscosity "//& "(KV_CONV) will be set to KD_CONV * PRANDTL_TURB.", & units='m2/s', default=1.00) call get_param(param_file, mdl, 'BV_SQR_CONV', CS%bv_sqr_conv, & - "Threshold for squared buoyancy frequency needed to trigger \n" // & + "Threshold for squared buoyancy frequency needed to trigger "//& "Brunt-Vaisala parameterization.", & units='1/s^2', default=0.0) diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 0e80f166c5..4f535197a7 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -82,9 +82,9 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, & "Parameterization of mixing due to double diffusion processes via CVMix") call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, & - "If true, turns on double diffusive processes via CVMix. \n"// & - "Note that double diffusive processes on viscosity are ignored \n"// & - "in CVMix, see http://cvmix.github.io/ for justification.",& + "If true, turns on double diffusive processes via CVMix. "//& + "Note that double diffusive processes on viscosity are ignored "//& + "in CVMix, see http://cvmix.github.io/ for justification.", & default=.false.) if (.not. CVMix_ddiff_init) return @@ -100,7 +100,7 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) units="nondim", default=2.55) call get_param(param_file, mdl, "KAPPA_DDIFF_S", CS%kappa_ddiff_s, & - "Leading coefficient in formula for salt-fingering regime \n"// & + "Leading coefficient in formula for salt-fingering regime "//& "for salinity diffusion.", units="m2 s-1", default=1.0e-4) call get_param(param_file, mdl, "DDIFF_EXP1", CS%ddiff_exp1, & diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 06fa74bdc7..9e0f6ca708 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -213,14 +213,14 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, & "Parameterization of shear-driven turbulence via CVMix (various options)") call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, & - "If true, use the Large-McWilliams-Doney (JGR 1994) \n"//& + "If true, use the Large-McWilliams-Doney (JGR 1994) "//& "shear mixing parameterization.", default=.false.) if (CS%use_LMD94) then NumberTrue=NumberTrue + 1 CS%Mix_Scheme='KPP' endif call get_param(param_file, mdl, "USE_PP81", CS%use_PP81, & - "If true, use the Pacanowski and Philander (JPO 1981) \n"//& + "If true, use the Pacanowski and Philander (JPO 1981) "//& "shear mixing parameterization.", default=.false.) if (CS%use_PP81) then NumberTrue = NumberTrue + 1 @@ -243,16 +243,16 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) "Leading coefficient in KPP shear mixing.", & units="nondim", default=5.e-3) call get_param(param_file, mdl, "RI_ZERO", CS%Ri_Zero, & - "Critical Richardson for KPP shear mixing,"// & - " NOTE this the internal mixing and this is"// & - " not for setting the boundary layer depth." & + "Critical Richardson for KPP shear mixing, "// & + "NOTE this the internal mixing and this is "// & + "not for setting the boundary layer depth." & ,units="nondim", default=0.8) call get_param(param_file, mdl, "KPP_EXP", CS%KPP_exp, & - "Exponent of unitless factor of diffusivities,"// & - " for KPP internal shear mixing scheme." & + "Exponent of unitless factor of diffusivities, "// & + "for KPP internal shear mixing scheme." & ,units="nondim", default=3.0) call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & - "If true, vertically smooth the Richardson"// & + "If true, vertically smooth the Richardson "// & "number by applying a 1-2-1 filter once.", & default = .false.) call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 12ee411831..e941ec3eea 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -144,12 +144,12 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) "Adding static vertical background mixing coefficients") call get_param(param_file, mdl, "KD", CS%Kd, & - "The background diapycnal diffusivity of density in the \n"//& - "interior. Zero or the molecular value, ~1e-7 m2 s-1, \n"//& + "The background diapycnal diffusivity of density in the "//& + "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& "may be used.", units="m2 s-1", scale=US%m_to_Z**2, fail_if_missing=.true.) call get_param(param_file, mdl, "KV", Kv, & - "The background kinematic viscosity in the interior. \n"//& + "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true.) @@ -172,13 +172,13 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) ! cannot be a NaN. else call get_param(param_file, mdl, "KDML", CS%Kdml, & - "If BULKMIXEDLAYER is false, KDML is the elevated \n"//& - "diapycnal diffusivity in the topmost HMIX of fluid. \n"//& + "If BULKMIXEDLAYER is false, KDML is the elevated "//& + "diapycnal diffusivity in the topmost HMIX of fluid. "//& "KDML is only used if BULKMIXEDLAYER is false.", & units="m2 s-1", default=CS%Kd*US%Z_to_m**2, scale=US%m_to_Z**2) call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & - "The prescribed depth over which the near-surface \n"//& - "viscosity and diffusivity are elevated when the bulk \n"//& + "The prescribed depth over which the near-surface "//& + "viscosity and diffusivity are elevated when the bulk "//& "mixed layer is not used.", units="m", scale=US%m_to_Z, fail_if_missing=.true.) endif @@ -186,10 +186,9 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) ! call openParameterBlock(param_file,'MOM_BACKGROUND_MIXING') - call get_param(param_file, mdl, "BRYAN_LEWIS_DIFFUSIVITY", & - CS%Bryan_Lewis_diffusivity, & - "If true, use a Bryan & Lewis (JGR 1979) like tanh \n"//& - "profile of background diapycnal diffusivity with depth. \n"//& + call get_param(param_file, mdl, "BRYAN_LEWIS_DIFFUSIVITY", CS%Bryan_Lewis_diffusivity, & + "If true, use a Bryan & Lewis (JGR 1979) like tanh "//& + "profile of background diapycnal diffusivity with depth. "//& "This is done via CVMix.", default=.false.) if (CS%Bryan_Lewis_diffusivity) then @@ -219,7 +218,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "HORIZ_VARYING_BACKGROUND", & CS%horiz_varying_background, & - "If true, apply vertically uniform, latitude-dependent background\n"//& + "If true, apply vertically uniform, latitude-dependent background "//& "diffusivity, as described in Danabasoglu et al., 2012", & default=.false.) @@ -248,7 +247,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) endif call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & - "Turbulent Prandtl number used to convert vertical \n"//& + "Turbulent Prandtl number used to convert vertical "//& "background diffusivities into viscosities.", & units="nondim", default=1.0) @@ -265,18 +264,16 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) endif - call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND", & - CS%Henyey_IGW_background, & - "If true, use a latitude-dependent scaling for the near \n"//& - "surface background diffusivity, as described in \n"//& + call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND", CS%Henyey_IGW_background, & + "If true, use a latitude-dependent scaling for the near "//& + "surface background diffusivity, as described in "//& "Harrison & Hallberg, JPO 2008.", default=.false.) if (CS%Henyey_IGW_background) call check_bkgnd_scheme(CS, "HENYEY_IGW_BACKGROUND") - call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND_NEW", & - CS%Henyey_IGW_background_new, & - "If true, use a better latitude-dependent scaling for the\n"//& - "background diffusivity, as described in \n"//& + call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND_NEW", CS%Henyey_IGW_background_new, & + "If true, use a better latitude-dependent scaling for the "//& + "background diffusivity, as described in "//& "Harrison & Hallberg, JPO 2008.", default=.false.) if (CS%Henyey_IGW_background_new) call check_bkgnd_scheme(CS, "HENYEY_IGW_BACKGROUND_NEW") @@ -288,22 +285,21 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) if (CS%Henyey_IGW_background) & call get_param(param_file, mdl, "HENYEY_N0_2OMEGA", CS%N0_2Omega, & - "The ratio of the typical Buoyancy frequency to twice \n"//& - "the Earth's rotation period, used with the Henyey \n"//& + "The ratio of the typical Buoyancy frequency to twice "//& + "the Earth's rotation period, used with the Henyey "//& "scaling from the mixing.", units="nondim", default=20.0) call get_param(param_file, mdl, "KD_TANH_LAT_FN", & CS%Kd_tanh_lat_fn, & - "If true, use a tanh dependence of Kd_sfc on latitude, \n"//& - "like CM2.1/CM2M. There is no physical justification \n"//& - "for this form, and it can not be used with \n"//& + "If true, use a tanh dependence of Kd_sfc on latitude, "//& + "like CM2.1/CM2M. There is no physical justification "//& + "for this form, and it can not be used with "//& "HENYEY_IGW_BACKGROUND.", default=.false.) if (CS%Kd_tanh_lat_fn) & - call get_param(param_file, mdl, "KD_TANH_LAT_SCALE", & - CS%Kd_tanh_lat_scale, & - "A nondimensional scaling for the range ofdiffusivities \n"//& - "with KD_TANH_LAT_FN. Valid values are in the range of \n"//& + call get_param(param_file, mdl, "KD_TANH_LAT_SCALE", CS%Kd_tanh_lat_scale, & + "A nondimensional scaling for the range ofdiffusivities "//& + "with KD_TANH_LAT_FN. Valid values are in the range of "//& "-2 to 2; 0.4 reproduces CM2M.", units="nondim", default=0.0) if (CS%Henyey_IGW_background .and. CS%Kd_tanh_lat_fn) call MOM_error(FATAL, & @@ -380,7 +376,7 @@ end subroutine sfc_bkgnd_mixing !> Calculates the vertical background diffusivities/viscosities -subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) +subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. @@ -388,9 +384,9 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< squared buoyancy frequency associated - !! with layers [s-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: kd_lay !< Diapycnal diffusivity of each layer - !! [Z2 s-1 ~> m2 s-1]. + !! with layers [T-2 ~> s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd_lay !< Diapycnal diffusivity of each layer + !! [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 s-1 ~> m2 s-1] integer, intent(in) :: j !< Meridional grid index @@ -447,7 +443,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) CS%Kd_bkgnd(i,j,K) = US%m_to_Z**2*Kd_col(K) enddo do k=1,nz - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*US%m_to_Z**2*(Kd_col(K) + Kd_col(K+1)) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_col(K) + Kd_col(K+1)) enddo enddo ! i loop @@ -460,7 +456,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) if (depth_c <= CS%Hmix) then ; CS%Kd_bkgnd(i,j,k) = CS%Kdml elseif (depth_c >= 2.0*CS%Hmix) then ; CS%Kd_bkgnd(i,j,k) = CS%Kd_sfc(i,j) else - Kd_lay(i,j,k) = ((CS%Kd_sfc(i,j) - CS%Kdml) * I_Hmix) * depth_c + & + Kd_lay(i,j,k) = US%T_to_s * ((CS%Kd_sfc(i,j) - CS%Kdml) * I_Hmix) * depth_c + & (2.0*CS%Kdml - CS%Kd_sfc(i,j)) endif @@ -506,7 +502,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) CS%kv_bkgnd(i,j,:) = CS%kd_bkgnd(i,j,:) * CS%prandtl_bkgnd ! Update Kd (uniform profile; no interpolation needed) - kd_lay(i,j,:) = CS%kd_bkgnd(i,j,1) + Kd_lay(i,j,:) = US%T_to_s * CS%kd_bkgnd(i,j,1) enddo @@ -514,15 +510,15 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) I_x30 = 2.0 / invcosh(CS%N0_2Omega*2.0) ! This is evaluated at 30 deg. do k=1,nz ; do i=is,ie abs_sin = max(epsilon,abs(sin(G%geoLatT(i,j)*deg_to_rad))) - N_2Omega = max(abs_sin,sqrt(N2_lay(i,k))*I_2Omega) + N_2Omega = max(abs_sin,sqrt(US%s_to_T**2 * N2_lay(i,k))*I_2Omega) N02_N2 = (CS%N0_2Omega/N_2Omega)**2 - Kd_lay(i,j,k) = max(CS%Kd_min, CS%Kd_sfc(i,j) * & + Kd_lay(i,j,k) = US%T_to_s * max(CS%Kd_min, CS%Kd_sfc(i,j) * & ((abs_sin * invcosh(N_2Omega/abs_sin)) * I_x30)*N02_N2) enddo ; enddo else do k=1,nz ; do i=is,ie - Kd_lay(i,j,k) = CS%Kd_sfc(i,j) + Kd_lay(i,j,k) = US%T_to_s * CS%Kd_sfc(i,j) enddo ; enddo endif @@ -532,7 +528,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, Kv, j, G, GV, US, CS) CS%kd_bkgnd(i,j,1) = 0.0; CS%kv_bkgnd(i,j,1) = 0.0 CS%kd_bkgnd(i,j,nz+1) = 0.0; CS%kv_bkgnd(i,j,nz+1) = 0.0 do k=2,nz - CS%Kd_bkgnd(i,j,k) = 0.5*(Kd_lay(i,j,K-1) + Kd_lay(i,j,K)) + CS%Kd_bkgnd(i,j,k) = US%s_to_T * (0.5*(Kd_lay(i,j,K-1) + Kd_lay(i,j,K))) CS%Kv_bkgnd(i,j,k) = CS%Kd_bkgnd(i,j,k) * CS%prandtl_bkgnd enddo enddo diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index be7d0ff08b..17b7bb5c15 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -3429,81 +3429,81 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) CS%nkml = GV%nkml call log_param(param_file, mdl, "NKML", CS%nkml, & - "The number of sublayers within the mixed layer if \n"//& + "The number of sublayers within the mixed layer if "//& "BULKMIXEDLAYER is true.", units="nondim", default=2) CS%nkbl = GV%nk_rho_varies - GV%nkml call log_param(param_file, mdl, "NKBL", CS%nkbl, & - "The number of variable density buffer layers if \n"//& + "The number of variable density buffer layers if "//& "BULKMIXEDLAYER is true.", units="nondim", default=2) call get_param(param_file, mdl, "MSTAR", CS%mstar, & - "The ratio of the friction velocity cubed to the TKE \n"//& + "The ratio of the friction velocity cubed to the TKE "//& "input to the mixed layer.", "units=nondim", default=1.2) call get_param(param_file, mdl, "NSTAR", CS%nstar, & - "The portion of the buoyant potential energy imparted by \n"//& - "surface fluxes that is available to drive entrainment \n"//& + "The portion of the buoyant potential energy imparted by "//& + "surface fluxes that is available to drive entrainment "//& "at the base of mixed layer when that energy is positive.", & units="nondim", default=0.15) call get_param(param_file, mdl, "BULK_RI_ML", CS%bulk_Ri_ML, & - "The efficiency with which mean kinetic energy released \n"//& - "by mechanically forced entrainment of the mixed layer \n"//& + "The efficiency with which mean kinetic energy released "//& + "by mechanically forced entrainment of the mixed layer "//& "is converted to turbulent kinetic energy.", units="nondim",& fail_if_missing=.true.) call get_param(param_file, mdl, "ABSORB_ALL_SW", CS%absorb_all_sw, & - "If true, all shortwave radiation is absorbed by the \n"//& + "If true, all shortwave radiation is absorbed by the "//& "ocean, instead of passing through to the bottom mud.", & default=.false.) call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & - "TKE_DECAY relates the vertical rate of decay of the \n"//& - "TKE available for mechanical entrainment to the natural \n"//& + "TKE_DECAY relates the vertical rate of decay of the "//& + "TKE available for mechanical entrainment to the natural "//& "Ekman depth.", units="nondim", default=2.5) call get_param(param_file, mdl, "NSTAR2", CS%nstar2, & - "The portion of any potential energy released by \n"//& - "convective adjustment that is available to drive \n"//& - "entrainment at the base of mixed layer. By default \n"//& + "The portion of any potential energy released by "//& + "convective adjustment that is available to drive "//& + "entrainment at the base of mixed layer. By default "//& "NSTAR2=NSTAR.", units="nondim", default=CS%nstar) call get_param(param_file, mdl, "BULK_RI_CONVECTIVE", CS%bulk_Ri_convective, & - "The efficiency with which convectively released mean \n"//& - "kinetic energy is converted to turbulent kinetic \n"//& + "The efficiency with which convectively released mean "//& + "kinetic energy is converted to turbulent kinetic "//& "energy. By default BULK_RI_CONVECTIVE=BULK_RI_ML.", & units="nondim", default=CS%bulk_Ri_ML) call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & - "The minimum mixed layer depth if the mixed layer depth \n"//& + "The minimum mixed layer depth if the mixed layer depth "//& "is determined dynamically.", units="m", default=0.0, scale=GV%m_to_H, & unscaled=Hmix_min_m) call get_param(param_file, mdl, "LIMIT_BUFFER_DETRAIN", CS%limit_det, & - "If true, limit the detrainment from the buffer layers \n"//& + "If true, limit the detrainment from the buffer layers "//& "to not be too different from the neighbors.", default=.false.) call get_param(param_file, mdl, "ALLOWED_DETRAIN_TEMP_CHG", CS%Allowed_T_chg, & - "The amount by which temperature is allowed to exceed \n"//& + "The amount by which temperature is allowed to exceed "//& "previous values during detrainment.", units="K", default=0.5) call get_param(param_file, mdl, "ALLOWED_DETRAIN_SALT_CHG", CS%Allowed_S_chg, & - "The amount by which salinity is allowed to exceed \n"//& + "The amount by which salinity is allowed to exceed "//& "previous values during detrainment.", units="PSU", default=0.1) call get_param(param_file, mdl, "ML_DT_DS_WEIGHT", CS%dT_dS_wt, & - "When forced to extrapolate T & S to match the layer \n"//& - "densities, this factor (in deg C / PSU) is combined \n"//& - "with the derivatives of density with T & S to determine \n"//& - "what direction is orthogonal to density contours. It \n"//& - "should be a typical value of (dR/dS) / (dR/dT) in \n"//& + "When forced to extrapolate T & S to match the layer "//& + "densities, this factor (in deg C / PSU) is combined "//& + "with the derivatives of density with T & S to determine "//& + "what direction is orthogonal to density contours. It "//& + "should be a typical value of (dR/dS) / (dR/dT) in "//& "oceanic profiles.", units="degC PSU-1", default=6.0) call get_param(param_file, mdl, "BUFFER_LAYER_EXTRAP_LIMIT", CS%BL_extrap_lim, & - "A limit on the density range over which extrapolation \n"//& - "can occur when detraining from the buffer layers, \n"//& - "relative to the density range within the mixed and \n"//& - "buffer layers, when the detrainment is going into the \n"//& - "lightest interior layer, nondimensional, or a negative \n"//& + "A limit on the density range over which extrapolation "//& + "can occur when detraining from the buffer layers, "//& + "relative to the density range within the mixed and "//& + "buffer layers, when the detrainment is going into the "//& + "lightest interior layer, nondimensional, or a negative "//& "value not to apply this limit.", units="nondim", default = -1.0) call get_param(param_file, mdl, "DEPTH_LIMIT_FLUXES", CS%H_limit_fluxes, & - "The surface fluxes are scaled away when the total ocean \n"//& + "The surface fluxes are scaled away when the total ocean "//& "depth is less than DEPTH_LIMIT_FLUXES.", & units="m", default=0.1*Hmix_min_m, scale=GV%m_to_H) call get_param(param_file, mdl, "OMEGA",CS%omega, & "The rotation rate of the earth.", units="s-1", & default=7.2921e-5) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & - "If true, use the absolute rotation rate instead of the \n"//& - "vertical component of rotation when setting the decay \n"//& + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then @@ -3511,58 +3511,58 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & - "When setting the decay scale for turbulence, use this \n"//& - "fraction of the absolute rotation rate blended with the \n"//& + "When setting the decay scale for turbulence, use this "//& + "fraction of the absolute rotation rate blended with the "//& "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & units="nondim", default=omega_frac_dflt) call get_param(param_file, mdl, "ML_RESORT", CS%ML_resort, & - "If true, resort the topmost layers by potential density \n"//& + "If true, resort the topmost layers by potential density "//& "before the mixed layer calculations.", default=.false.) if (CS%ML_resort) & call get_param(param_file, mdl, "ML_PRESORT_NK_CONV_ADJ", CS%ML_presort_nz_conv_adj, & - "Convectively mix the first ML_PRESORT_NK_CONV_ADJ \n"//& + "Convectively mix the first ML_PRESORT_NK_CONV_ADJ "//& "layers before sorting when ML_RESORT is true.", & units="nondim", default=0, fail_if_missing=.true.) ! Fail added by AJA. ! This gives a minimum decay scale that is typically much less than Angstrom. ustar_min_dflt = 2e-4*CS%omega*(GV%Angstrom_m + GV%H_to_m*GV%H_subroundoff) call get_param(param_file, mdl, "BML_USTAR_MIN", CS%ustar_min, & - "The minimum value of ustar that should be used by the \n"//& - "bulk mixed layer model in setting vertical TKE decay \n"//& + "The minimum value of ustar that should be used by the "//& + "bulk mixed layer model in setting vertical TKE decay "//& "scales. This must be greater than 0.", units="m s-1", & default=ustar_min_dflt, scale=US%m_to_Z) if (CS%ustar_min<=0.0) call MOM_error(FATAL, "BML_USTAR_MIN must be positive.") call get_param(param_file, mdl, "RESOLVE_EKMAN", CS%Resolve_Ekman, & - "If true, the NKML>1 layers in the mixed layer are \n"//& - "chosen to optimally represent the impact of the Ekman \n"//& - "transport on the mixed layer TKE budget. Otherwise, \n"//& - "the sublayers are distributed uniformly through the \n"//& + "If true, the NKML>1 layers in the mixed layer are "//& + "chosen to optimally represent the impact of the Ekman "//& + "transport on the mixed layer TKE budget. Otherwise, "//& + "the sublayers are distributed uniformly through the "//& "mixed layer.", default=.false.) call get_param(param_file, mdl, "CORRECT_ABSORPTION_DEPTH", CS%correct_absorption, & - "If true, the average depth at which penetrating shortwave \n"//& - "radiation is absorbed is adjusted to match the average \n"//& - "heating depth of an exponential profile by moving some \n"//& + "If true, the average depth at which penetrating shortwave "//& + "radiation is absorbed is adjusted to match the average "//& + "heating depth of an exponential profile by moving some "//& "of the heating upward in the water column.", default=.false.) call get_param(param_file, mdl, "DO_RIVERMIX", CS%do_rivermix, & - "If true, apply additional mixing whereever there is \n"//& - "runoff, so that it is mixed down to RIVERMIX_DEPTH, \n"//& + "If true, apply additional mixing wherever there is "//& + "runoff, so that it is mixed down to RIVERMIX_DEPTH, "//& "if the ocean is that deep.", default=.false.) if (CS%do_rivermix) & call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & - "The depth to which rivers are mixed if DO_RIVERMIX is \n"//& + "The depth to which rivers are mixed if DO_RIVERMIX is "//& "defined.", units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & - "If true, use the fluxes%runoff_Hflx field to set the \n"//& + "If true, use the fluxes%runoff_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & default=.false.) call get_param(param_file, mdl, "USE_CALVING_HEAT_CONTENT", CS%use_calving_heat_content, & - "If true, use the fluxes%calving_Hflx field to set the \n"//& + "If true, use the fluxes%calving_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*froz_runoff.", & default=.false.) call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", & CS%allow_clocks_in_omp_loops, & - "If true, clocks can be called from inside loops that can \n"//& + "If true, clocks can be called from inside loops that can "//& "be threaded. To run with multiple threads, set to False.", & default=.true.) @@ -3602,17 +3602,17 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) !CS%lim_det_dH_sfc = 0.5 ; CS%lim_det_dH_bathy = 0.2 ! Technically these should not get used if limit_det is false? if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) then call get_param(param_file, mdl, "LIMIT_BUFFER_DET_DH_SFC", CS%lim_det_dH_sfc, & - "The fractional limit in the change between grid points \n"//& + "The fractional limit in the change between grid points "//& "of the surface region (mixed & buffer layer) thickness.", & units="nondim", default=0.5) call get_param(param_file, mdl, "LIMIT_BUFFER_DET_DH_BATHY", CS%lim_det_dH_bathy, & - "The fraction of the total depth by which the thickness \n"//& - "of the surface region (mixed & buffer layer) is allowed \n"//& + "The fraction of the total depth by which the thickness "//& + "of the surface region (mixed & buffer layer) is allowed "//& "to change between grid points.", units="nondim", default=0.2) endif call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, temperature and salinity are used as state \n"//& + "If true, temperature and salinity are used as state "//& "variables.", default=.true.) CS%nsw = 0 if (use_temperature) then diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index e8b4500bbc..5259d4ed25 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -322,10 +322,11 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) integer, optional, intent(in) :: halo !< Halo width over which to work ! local variables - real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement - real :: S_min !< The minimum salinity - real :: mc !< A layer's mass kg m-2 . + real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement [gSalt m-2] + real :: S_min !< The minimum salinity [ppt]. + real :: mc !< A layer's mass [kg m-2]. integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -333,17 +334,15 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) ! call cpu_clock_begin(id_clock_adjust_salt) -!### MAKE THIS A RUN_TIME PARAMETER. COULD IT BE 0? - S_min = 0.01 + S_min = tv%min_salinity salt_add_col(:,:) = 0.0 -!$OMP parallel do default(none) shared(is,ie,js,je,nz,G,GV,tv,h,salt_add_col, S_min) & -!$OMP private(mc) + !$OMP parallel do default(none) private(mc) do j=js,je do k=nz,1,-1 ; do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .and. & - ((tv%S(i,j,k) < S_min) .or. (salt_add_col(i,j) > 0.0))) then + if ( (G%mask2dT(i,j) > 0.0) .and. & + ((tv%S(i,j,k) < S_min) .or. (salt_add_col(i,j) > 0.0)) ) then mc = GV%H_to_kg_m2 * h(i,j,k) if (h(i,j,k) <= 10.0*GV%Angstrom_H) then ! Very thin layers should not be adjusted by the salt flux @@ -351,14 +350,12 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) salt_add_col(i,j) = salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) tv%S(i,j,k) = S_min endif + elseif (salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) <= 0.0) then + tv%S(i,j,k) = tv%S(i,j,k) - salt_add_col(i,j) / mc + salt_add_col(i,j) = 0.0 else - if (salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) <= 0.0) then - tv%S(i,j,k) = tv%S(i,j,k) - salt_add_col(i,j)/mc - salt_add_col(i,j) = 0.0 - else - salt_add_col(i,j) = salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) - tv%S(i,j,k) = S_min - endif + salt_add_col(i,j) = salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) + tv%S(i,j,k) = S_min endif endif enddo ; enddo @@ -643,7 +640,8 @@ end subroutine find_uv_at_h !> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. !> This routine is appropriate in MOM_diabatic_driver due to its position within the time stepping. -subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, id_N2subML, id_MLDsq) +subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & + id_N2subML, id_MLDsq, dz_subML) type(ocean_grid_type), intent(in) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -656,19 +654,25 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD + real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML + !! or 50 m if missing [Z ~> m] ! Local variables real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [kg m-3]. - real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [Pa]. - real, dimension(SZI_(G)) :: dK, dKm1, d1 ! Depths [Z ~> m]. - real, dimension(SZI_(G)) :: rhoSurf, rhoAtK, rho1 ! Densities used for N2 [kg m-3]. + real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [Pa]. + real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m]. + real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [degC]. + real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [ppt]. + real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [kg m-3]. + real, dimension(SZI_(G)) :: dK, dKm1 ! Depths [Z ~> m]. + real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixedlayer depth [kg m-3]. real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [s-2]. real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. - real :: Rho_x_gE ! The product of density, gravitational acceleartion and a unit - ! conversion factor [kg m-1 Z-1 s-2 ~> kg m-2 s-2]. + logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 + ! have been stored already. real :: gE_Rho0 ! The gravitational acceleration divided by a mean density [m4 s-2 kg-1]. - real :: dz_subML ! Depth below ML over which to diagnose stratification [Z ~> m]. + real :: dH_subML ! Depth below ML over which to diagnose stratification [H ~> m]. integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ real :: aFac, ddRho @@ -676,12 +680,12 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, id_SQ = -1 ; if (PRESENT(id_N2subML)) id_SQ = id_MLDsq - Rho_x_gE = GV%g_Earth * GV%Rho0 gE_rho0 = US%m_to_Z**2 * GV%g_Earth / GV%Rho0 - dz_subML = 50.*US%m_to_Z + dH_subML = 50.*GV%m_to_H ; if (present(dz_subML)) dH_subML = GV%Z_to_H*dz_subML is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - pRef_MLD(:) = 0. ; pRef_N2(:) = 0. + + pRef_MLD(:) = 0.0 do j=js,je do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is, ie-is+1, tv%eqn_of_state) @@ -689,11 +693,10 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, deltaRhoAtK(i) = 0. MLD(i,j) = 0. if (id_N2>0) then - subMLN2(i,j) = 0. - rho1(i) = 0. - d1(i) = 0. - pRef_N2(i) = Rho_x_gE * h(i,j,1) * GV%H_to_Z ! Boussinesq approximation!!!! ????? - !### This should be: pRef_N2(i) = GV%H_to_Pa * h(i,j,1) ! This might change answers at roundoff. + subMLN2(i,j) = 0.0 + H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. endif enddo do k=2,nz @@ -702,27 +705,23 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K enddo - ! Stratification, N2, immediately below the mixed layer, averaged over at least 50 m. + ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding + ! the cells that extend over at least dz_subML. if (id_N2>0) then - do i=is,ie - pRef_N2(i) = pRef_N2(i) + Rho_x_gE * h(i,j,k) * GV%H_to_Z ! Boussinesq approximation!!!! ????? - !### This should be: pRef_N2(i) = pRev_N2(i) + GV%H_to_Pa * h(i,j,k) - !### This might change answers at roundoff. - enddo - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_N2, rhoAtK, is, ie-is+1, tv%eqn_of_state) - do i=is,ie - if (MLD(i,j)>0. .and. subMLN2(i,j)==0.) then ! This block is below the mixed layer - if (d1(i)==0.) then ! Record the density, depth and pressure, immediately below the ML - rho1(i) = rhoAtK(i) - d1(i) = dK(i) - !### It looks to me like there is bad logic here. - RWH - ! Use pressure at the bottom of the upper layer used in calculating d/dz rho - pRef_N2(i) = pRef_N2(i) + Rho_x_gE * h(i,j,k) * GV%H_to_Z ! Boussinesq approximation!!!! ????? - !### This line should be: pRef_N2(i) = pRev_N2(i) + GV%H_to_Pa * h(i,j,k) - !### This might change answers at roundoff. - endif - if (d1(i)>0. .and. dK(i)-d1(i)>=dz_subML) then - subMLN2(i,j) = gE_rho0 * (rho1(i)-rhoAtK(i)) / (d1(i) - dK(i)) + do i=is,ie + if (MLD(i,j)==0.0) then ! Still in the mixed layer. + H_subML(i) = H_subML(i) + h(i,j,k) + elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. + if (dH_N2(i)==0.0) then ! Record the temperature, salinity, pressure, immediately below the ML + T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) + H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. + dH_N2(i) = 0.5 * h(i,j,k) + elseif (dH_N2(i) + h(i,j,k) < dH_subML) then + dH_N2(i) = dH_N2(i) + h(i,j,k) + else ! This layer includes the base of the region where N2 is calculated. + T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) + dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) + N2_region_set(i) = .true. endif endif enddo ! i-loop @@ -744,11 +743,21 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, enddo ! k-loop do i=is,ie if ((MLD(i,j)==0.) .and. (deltaRhoAtK(i)0 .and. subMLN2(i,j)==0. .and. d1(i)>0. .and. dK(i)-d1(i)>0.) then - ! ! Use what ever stratification we can, measured over what ever distance is available - ! subMLN2(i,j) = gE_rho0 * (rho1(i)-rhoAtK(i)) / (d1(i) - dK(i)) - ! endif enddo + + if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. + do i=is,ie ; pRef_N2(i) = GV%H_to_Pa * (H_subML(i) + 0.5*dH_N2(i)) ; enddo + ! if ((.not.N2_region_set(i)) .and. (dH_N2(i) > 0.5*dH_subML)) then + ! ! Use whatever stratification we can, measured over whatever distance is available? + ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) + ! N2_region_set(i) = .true. + ! endif + call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, is, ie-is+1, tv%eqn_of_state) + call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, is, ie-is+1, tv%eqn_of_state) + do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then + subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) + endif ; enddo + endif enddo ! j-loop if (id_MLD > 0) call post_data(id_MLD, MLD, diagPtr) @@ -1101,13 +1110,12 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, h, tv, & ! Diagnostics of heat content associated with mass fluxes if (associated(fluxes%heat_content_massin)) & fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & - tv%T(i,j,k) * max(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt + T2d(i,k) * max(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & - tv%T(i,j,k) * min(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt + T2d(i,k) * min(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & - tv%T(i,j,k) * dThickness * GV%H_to_kg_m2 -!### NOTE: tv%T should be T2d in the expressions above. + T2d(i,k) * dThickness * GV%H_to_kg_m2 ! Update state by the appropriate increment. hOld = h2d(i,k) ! Keep original thickness in hand @@ -1329,31 +1337,31 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori "The following parameters are used for auxiliary diabatic processes.") call get_param(param_file, mdl, "RECLAIM_FRAZIL", CS%reclaim_frazil, & - "If true, try to use any frazil heat deficit to cool any\n"//& - "overlying layers down to the freezing point, thereby \n"//& - "avoiding the creation of thin ice when the SST is above \n"//& + "If true, try to use any frazil heat deficit to cool any "//& + "overlying layers down to the freezing point, thereby "//& + "avoiding the creation of thin ice when the SST is above "//& "the freezing point.", default=.true.) call get_param(param_file, mdl, "PRESSURE_DEPENDENT_FRAZIL", & CS%pressure_dependent_frazil, & - "If true, use a pressure dependent freezing temperature \n"//& - "when making frazil. The default is false, which will be \n"//& + "If true, use a pressure dependent freezing temperature "//& + "when making frazil. The default is false, which will be "//& "faster but is inappropriate with ice-shelf cavities.", & default=.false.) if (use_ePBL) then call get_param(param_file, mdl, "IGNORE_FLUXES_OVER_LAND", CS%ignore_fluxes_over_land,& - "If true, the model does not check if fluxes are being applied\n"//& - "over land points. This is needed when the ocean is coupled \n"//& - "with ice shelves and sea ice, since the sea ice mask needs to \n"//& - "be different than the ocean mask to avoid sea ice formation \n"//& + "If true, the model does not check if fluxes are being applied "//& + "over land points. This is needed when the ocean is coupled "//& + "with ice shelves and sea ice, since the sea ice mask needs to "//& + "be different than the ocean mask to avoid sea ice formation "//& "under ice shelves. This flag only works when use_ePBL = True.", default=.false.) call get_param(param_file, mdl, "DO_RIVERMIX", CS%do_rivermix, & - "If true, apply additional mixing whereever there is \n"//& - "runoff, so that it is mixed down to RIVERMIX_DEPTH \n"//& + "If true, apply additional mixing wherever there is "//& + "runoff, so that it is mixed down to RIVERMIX_DEPTH "//& "if the ocean is that deep.", default=.false.) if (CS%do_rivermix) & call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & - "The depth to which rivers are mixed if DO_RIVERMIX is \n"//& + "The depth to which rivers are mixed if DO_RIVERMIX is "//& "defined.", units="m", default=0.0, scale=US%m_to_Z) else CS%do_rivermix = .false. ; CS%rivermix_depth = 0.0 ; CS%ignore_fluxes_over_land = .false. @@ -1361,11 +1369,11 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori if (GV%nkml == 0) then call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & - "If true, use the fluxes%runoff_Hflx field to set the \n"//& + "If true, use the fluxes%runoff_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & default=.false.) call get_param(param_file, mdl, "USE_CALVING_HEAT_CONTENT", CS%use_calving_heat_content, & - "If true, use the fluxes%calving_Hflx field to set the \n"//& + "If true, use the fluxes%calving_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*froz_runoff.", & default=.false.) else diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 24a529716d..25d4eadb7d 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -20,7 +20,6 @@ module MOM_diabatic_driver use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init, diag_grid_storage_end use MOM_diag_mediator, only : diag_copy_diag_to_storage, diag_copy_storage_to_diag use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids -use MOM_diag_to_Z, only : diag_to_Z_CS, register_Zint_diag, calc_Zint_diags use MOM_diapyc_energy_req, only : diapyc_energy_req_init, diapyc_energy_req_end use MOM_diapyc_energy_req, only : diapyc_energy_req_calc, diapyc_energy_req_test, diapyc_energy_req_CS use MOM_CVMix_conv, only : CVMix_conv_init, CVMix_conv_cs @@ -43,7 +42,6 @@ module MOM_diabatic_driver use MOM_forcing_type, only : calculateBuoyancyFlux2d, forcing_SinglePointPrint use MOM_geothermal, only : geothermal, geothermal_init, geothermal_end, geothermal_CS use MOM_grid, only : ocean_grid_type -use MOM_io, only : vardesc, var_desc use MOM_int_tide_input, only : set_int_tide_input, int_tide_input_init use MOM_int_tide_input, only : int_tide_input_end, int_tide_input_CS, int_tide_input_type use MOM_interface_heights, only : find_eta @@ -174,6 +172,8 @@ module MOM_diabatic_driver logical :: debug_energy_req !< If true, test the mixing energy requirement code. type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output real :: MLDdensityDifference !< Density difference used to determine MLD_user + real :: dz_subML_N2 !< The distance over which to calculate a diagnostic of the + !! average stratification at the base of the mixed layer [Z ~> m]. integer :: nsw !< SW_NBANDS !>@{ Diagnostic IDs @@ -181,9 +181,8 @@ module MOM_diabatic_driver integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds (BDM) integer :: id_wd = -1, id_ea = -1, id_eb = -1 ! used by layer diabatic integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_ea_s = -1, id_eb_s = -1 - integer :: id_ea_t = -1, id_eb_t = -1, id_Kd_z = -1 + integer :: id_ea_t = -1, id_eb_t = -1 integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 - integer :: id_Tdif_z = -1, id_Tadv_z = -1, id_Sdif_z = -1, id_Sadv_z = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 integer :: id_subMLN2 = -1, id_brine_lay = -1 @@ -236,7 +235,6 @@ module MOM_diabatic_driver type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() !< Control structure for a child module type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() !< Control structure for a child module type(optics_type), pointer :: optics => NULL() !< Control structure for a child module - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() !< Control structure for a child module type(KPP_CS), pointer :: KPP_CSp => NULL() !< Control structure for a child module type(tidal_mixing_cs), pointer :: tidal_mixing_csp => NULL() !< Control structure for a child module type(CVMix_conv_cs), pointer :: CVMix_conv_csp => NULL() !< Control structure for a child module @@ -298,7 +296,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! one time step [H ~> m or kg m-2] eb_t, & ! amount of fluid entrained from the layer below within ! one time step [H ~> m or kg m-2] - Kd_lay, & ! diapycnal diffusivity of layers [Z2 s-1 ~> m2 s-1] + Kd_lay, & ! diapycnal diffusivity of layers [Z2 T-1 ~> m2 s-1] h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] h_prebound, & ! initial layer thicknesses [H ~> m or kg m-2] ! hold, & ! layer thickness before diapycnal entrainment, and later @@ -329,7 +327,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! near the boundaries [H ~> m or kg m-2] (for Bous or non-Bouss) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), target :: & - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 s-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] Kd_heat, & ! diapycnal diffusivity of heat [Z2 s-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 s-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 s-1 ~> m2 s-1] @@ -381,9 +379,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real :: dt_mix ! amount of time over which to apply mixing [s] real :: Idt ! inverse time step [s-1] - type(p3d) :: z_ptrs(7) ! pointers to diagnostics to be interpolated to depth - integer :: num_z_diags ! number of diagnostics to be interpolated to depth - integer :: z_ids(7) ! id numbers of diagnostics to be interpolated to depth integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m, halo @@ -576,8 +571,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_salt(i,j,k) = Kd_int(i,j,K) - Kd_heat(i,j,k) = Kd_int(i,j,K) + Kd_salt(i,j,k) = US%s_to_T * Kd_int(i,j,K) + Kd_heat(i,j,k) = US%s_to_T * Kd_int(i,j,K) enddo ; enddo ; enddo ! Add contribution from double diffusion if (associated(visc%Kd_extra_S)) then @@ -899,8 +894,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call diag_update_remap_grids(CS%diag) ! diagnostics - if ((CS%id_Tdif > 0) .or. (CS%id_Tdif_z > 0) .or. & - (CS%id_Tadv > 0) .or. (CS%id_Tadv_z > 0)) then + if ((CS%id_Tdif > 0) .or. (CS%id_Tadv > 0)) then do j=js,je ; do i=is,ie Tdif_flx(i,j,1) = 0.0 ; Tdif_flx(i,j,nz+1) = 0.0 Tadv_flx(i,j,1) = 0.0 ; Tadv_flx(i,j,nz+1) = 0.0 @@ -913,8 +907,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 0.5*(tv%T(i,j,k-1) + tv%T(i,j,k)) enddo ; enddo ; enddo endif - if ((CS%id_Sdif > 0) .or. (CS%id_Sdif_z > 0) .or. & - (CS%id_Sadv > 0) .or. (CS%id_Sadv_z > 0)) then + if ((CS%id_Sdif > 0) .or. (CS%id_Sadv > 0)) then do j=js,je ; do i=is,ie Sdif_flx(i,j,1) = 0.0 ; Sdif_flx(i,j,nz+1) = 0.0 Sadv_flx(i,j,1) = 0.0 ; Sadv_flx(i,j,nz+1) = 0.0 @@ -1100,7 +1093,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03, G, GV, US, CS%diag, & - id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq) + id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) endif if (CS%id_MLD_0125 > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, US, CS%diag) @@ -1122,31 +1115,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call disable_averaging(CS%diag) - num_z_diags = 0 - if (CS%id_Kd_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Kd_z ; z_ptrs(num_z_diags)%p => Kd_int - endif - if (CS%id_Tdif_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Tdif_z ; z_ptrs(num_z_diags)%p => Tdif_flx - endif - if (CS%id_Tadv_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Tadv_z ; z_ptrs(num_z_diags)%p => Tadv_flx - endif - if (CS%id_Sdif_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Sdif_z ; z_ptrs(num_z_diags)%p => Sdif_flx - endif - if (CS%id_Sadv_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Sadv_z ; z_ptrs(num_z_diags)%p => Sadv_flx - endif - - if (num_z_diags > 0) & - call calc_Zint_diags(h, z_ptrs, z_ids, num_z_diags, G, GV, CS%diag_to_Z_CSp) - if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G) if (showCallTree) call callTree_leave("diabatic()") @@ -1182,7 +1150,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en ! one time step [H ~> m or kg m-2] eb, & ! amount of fluid entrained from the layer below within ! one time step [H ~> m or kg m-2] - Kd_lay, & ! diapycnal diffusivity of layers [Z2 s-1 ~> m2 s-1] + Kd_lay, & ! diapycnal diffusivity of layers [Z2 T-1 ~> m2 s-1] h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] h_prebound, & ! initial layer thicknesses [H ~> m or kg m-2] hold, & ! layer thickness before diapycnal entrainment, and later @@ -1215,7 +1183,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en ! near the boundaries [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), target :: & - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 s-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] Kd_heat, & ! diapycnal diffusivity of heat [Z2 s-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 s-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 s-1 ~> m2 s-1] @@ -1267,9 +1235,6 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en real :: dt_mix ! amount of time over which to apply mixing [s] real :: Idt ! inverse time step [s-1] - type(p3d) :: z_ptrs(7) ! pointers to diagnostics to be interpolated to depth - integer :: num_z_diags ! number of diagnostics to be interpolated to depth - integer :: z_ids(7) ! id numbers of diagnostics to be interpolated to depth integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m, halo @@ -1510,8 +1475,10 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G) - call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=US%Z_to_m**2) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) endif @@ -1528,8 +1495,8 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_salt(i,j,k) = Kd_int(i,j,K) - Kd_heat(i,j,k) = Kd_int(i,j,K) + Kd_salt(i,j,k) = US%s_to_T * Kd_int(i,j,K) + Kd_heat(i,j,k) = US%s_to_T * Kd_int(i,j,K) enddo ; enddo ; enddo if (associated(visc%Kd_extra_S)) then !$OMP parallel do default(shared) @@ -1560,18 +1527,18 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en if (.not. CS%KPPisPassive) then !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_int(i,j,K) = min( Kd_salt(i,j,k), Kd_heat(i,j,k) ) + Kd_int(i,j,K) = US%T_to_s * min( Kd_salt(i,j,k), Kd_heat(i,j,k) ) enddo ; enddo ; enddo if (associated(visc%Kd_extra_S)) then !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kd_extra_S(i,j,k) = (Kd_salt(i,j,k) - Kd_int(i,j,K)) + visc%Kd_extra_S(i,j,k) = (Kd_salt(i,j,k) - US%s_to_T * Kd_int(i,j,K)) enddo ; enddo ; enddo endif if (associated(visc%Kd_extra_T)) then !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kd_extra_T(i,j,k) = (Kd_heat(i,j,k) - Kd_int(i,j,K)) + visc%Kd_extra_T(i,j,k) = (Kd_heat(i,j,k) - US%s_to_T * Kd_int(i,j,K)) enddo ; enddo ; enddo endif endif ! not passive @@ -1582,8 +1549,10 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en call MOM_state_chksum("after KPP", u, v, h, G, GV, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G) - call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=US%Z_to_m**2) - call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) + call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) endif endif ! endif for KPP @@ -1595,7 +1564,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en !!!!!!!! GMM, the following needs to be checked !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !### The vertical extent here is more limited that Kv_slow or Kd_int; it might be k=1,nz+1. do k=1,nz ; do j=js,je ; do i=is,ie - Kd_int(i,j,K) = Kd_int(i,j,K) + CS%CVMix_conv_csp%kd_conv(i,j,k) + Kd_int(i,j,K) = Kd_int(i,j,K) + US%T_to_s * CS%CVMix_conv_csp%kd_conv(i,j,k) visc%Kv_slow(i,j,k) = visc%Kv_slow(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) enddo ; enddo ; enddo !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1662,7 +1631,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en !$OMP private(hval) do k=2,nz ; do j=js,je ; do i=is,ie hval=1.0/(h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ea(i,j,k) = (GV%Z_to_H**2) * dt * hval * Kd_int(i,j,K) + ea(i,j,k) = (GV%Z_to_H**2) * dt * hval * (US%s_to_T * Kd_int(i,j,K)) eb(i,j,k-1) = ea(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie @@ -1677,7 +1646,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en ! Calculate appropriately limited diapycnal mass fluxes to account ! for diapycnal diffusion and advection. Sets: ea, eb. Changes: kb call Entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, US, CS%entrain_diffusive_CSp, & - ea, eb, kb, Kd_Lay=Kd_lay, Kd_int=Kd_int) + ea, eb, kb, Kd_lay=Kd_lay, Kd_int=Kd_int) call cpu_clock_end(id_clock_entrain) if (showCallTree) call callTree_waypoint("done with Entrainment_diffusive (diabatic)") @@ -1749,11 +1718,11 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) eb(i,j,k-1) = eb(i,j,k-1) + Ent_int ea(i,j,k) = ea(i,j,k) + Ent_int - Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here + Kd_int(i,j,K) = Kd_int(i,j,K) + US%T_to_s * Kd_add_here ! for diagnostics - Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_int(i,j,K) - Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_int(i,j,K) + Kd_heat(i,j,K) = Kd_heat(i,j,K) + US%T_to_s * Kd_int(i,j,K) + Kd_salt(i,j,K) = Kd_salt(i,j,K) + US%T_to_s * Kd_int(i,j,K) enddo ; enddo ; enddo @@ -2046,11 +2015,13 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en ! Whenever thickness changes let the diag manager know, as the ! target grids for vertical remapping may need to be regenerated. + if (CS%id_dudt_dia > 0 .or. CS%id_dvdt_dia > 0) & + ! Remapped d[uv]dt_dia require east/north halo updates of h + call pass_var(h, G%domain, To_West+To_South+Omit_Corners, halo=1) call diag_update_remap_grids(CS%diag) ! diagnostics - if ((CS%id_Tdif > 0) .or. (CS%id_Tdif_z > 0) .or. & - (CS%id_Tadv > 0) .or. (CS%id_Tadv_z > 0)) then + if ((CS%id_Tdif > 0) .or. (CS%id_Tadv > 0)) then do j=js,je ; do i=is,ie Tdif_flx(i,j,1) = 0.0 ; Tdif_flx(i,j,nz+1) = 0.0 Tadv_flx(i,j,1) = 0.0 ; Tadv_flx(i,j,nz+1) = 0.0 @@ -2063,8 +2034,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en 0.5*(tv%T(i,j,k-1) + tv%T(i,j,k)) enddo ; enddo ; enddo endif - if ((CS%id_Sdif > 0) .or. (CS%id_Sdif_z > 0) .or. & - (CS%id_Sadv > 0) .or. (CS%id_Sadv_z > 0)) then + if ((CS%id_Sdif > 0) .or. (CS%id_Sadv > 0)) then do j=js,je ; do i=is,ie Sdif_flx(i,j,1) = 0.0 ; Sdif_flx(i,j,nz+1) = 0.0 Sadv_flx(i,j,1) = 0.0 ; Sadv_flx(i,j,nz+1) = 0.0 @@ -2397,7 +2367,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03, G, GV, US, CS%diag, & - id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq) + id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) endif if (CS%id_MLD_0125 > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, US, CS%diag) @@ -2419,31 +2389,6 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en call disable_averaging(CS%diag) - num_z_diags = 0 - if (CS%id_Kd_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Kd_z ; z_ptrs(num_z_diags)%p => Kd_int - endif - if (CS%id_Tdif_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Tdif_z ; z_ptrs(num_z_diags)%p => Tdif_flx - endif - if (CS%id_Tadv_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Tadv_z ; z_ptrs(num_z_diags)%p => Tadv_flx - endif - if (CS%id_Sdif_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Sdif_z ; z_ptrs(num_z_diags)%p => Sdif_flx - endif - if (CS%id_Sadv_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Sadv_z ; z_ptrs(num_z_diags)%p => Sadv_flx - endif - - if (num_z_diags > 0) & - call calc_Zint_diags(h, z_ptrs, z_ids, num_z_diags, G, GV, CS%diag_to_Z_CSp) - if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G) if (showCallTree) call callTree_leave("diabatic()") @@ -2470,7 +2415,7 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & if (present(evap_CFL_limit)) evap_CFL_limit = CS%evap_CFL_limit if (present(minimum_forcing_depth)) minimum_forcing_depth = CS%minimum_forcing_depth -end subroutine +end subroutine extract_diabatic_member !> Routine called for adiabatic physics subroutine adiabatic(h, tv, fluxes, dt, G, GV, CS) @@ -2728,7 +2673,7 @@ end subroutine diagnose_frazil_tendency !! tracer column functions to be called without allowing any !! of the diabatic processes to be used. subroutine adiabatic_driver_init(Time, G, param_file, diag, CS, & - tracer_flow_CSp, diag_to_Z_CSp) + tracer_flow_CSp) type(time_type), intent(in) :: Time !< current model time type(ocean_grid_type), intent(in) :: G !< model grid structure type(param_file_type), intent(in) :: param_file !< the file to parse for parameter values @@ -2736,7 +2681,6 @@ subroutine adiabatic_driver_init(Time, G, param_file, diag, CS, & type(diabatic_CS), pointer :: CS !< module control structure type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< pointer to control structure of the !! tracer flow control module - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< pointer to Z-diagnostics control structure ! This "include" declares and sets the variable "version". #include "version_variable.h" @@ -2750,7 +2694,6 @@ subroutine adiabatic_driver_init(Time, G, param_file, diag, CS, & CS%diag => diag if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp - if (associated(diag_to_Z_CSp)) CS%diag_to_Z_CSp => diag_to_Z_CSp ! Set default, read and log parameters call log_version(param_file, mdl, version, & @@ -2762,7 +2705,7 @@ end subroutine adiabatic_driver_init !> This routine initializes the diabatic driver module. subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, diag, & ADp, CDp, CS, tracer_flow_CSp, sponge_CSp, & - ALE_sponge_CSp, diag_to_Z_CSp) + ALE_sponge_CSp) type(time_type), target :: Time !< model time type(ocean_grid_type), intent(inout) :: G !< model grid structure type(verticalGrid_type), intent(in) :: GV !< model vertical grid structure @@ -2778,12 +2721,10 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di !! tracer flow control module type(sponge_CS), pointer :: sponge_CSp !< pointer to the sponge module control structure type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< pointer to the ALE sponge module control structure - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< pointer to the Z-diagnostics control structure real :: Kd integer :: num_mode logical :: use_temperature, differentialDiffusion - type(vardesc) :: vd ! This "include" declares and sets the variable "version". #include "version_variable.h" @@ -2809,7 +2750,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp if (associated(sponge_CSp)) CS%sponge_CSp => sponge_CSp if (associated(ALE_sponge_CSp)) CS%ALE_sponge_CSp => ALE_sponge_CSp - if (associated(diag_to_Z_CSp)) CS%diag_to_Z_CSp => diag_to_Z_CSp CS%useALEalgorithm = useALEalgorithm CS%bulkmixedlayer = (GV%nkml > 0) @@ -2818,27 +2758,27 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call log_version(param_file, mdl, version, & "The following parameters are used for diabatic processes.") call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& - "specified via calls to initialize_sponge and possibly \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& + "specified via calls to initialize_sponge and possibly "//& "set_up_sponge_field.", default=.false.) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, temperature and salinity are used as state \n"//& + "If true, temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", CS%use_energetic_PBL, & - "If true, use an implied energetics planetary boundary \n"//& - "layer scheme to determine the diffusivity and viscosity \n"//& + "If true, use an implied energetics planetary boundary "//& + "layer scheme to determine the diffusivity and viscosity "//& "in the surface boundary layer.", default=.false.) call get_param(param_file, mdl, "EPBL_IS_ADDITIVE", CS%ePBL_is_additive, & - "If true, the diffusivity from ePBL is added to all\n"//& - "other diffusivities. Otherwise, the larger of kappa-\n"//& - "shear and ePBL diffusivities are used.", default=.true.) + "If true, the diffusivity from ePBL is added to all "//& + "other diffusivities. Otherwise, the larger of kappa-shear "//& + "and ePBL diffusivities are used.", default=.true.) call get_param(param_file, mdl, "DOUBLE_DIFFUSION", differentialDiffusion, & "If true, apply parameterization of double-diffusion.", & default=.false. ) call get_param(param_file, mdl, "USE_KPP", CS%use_KPP, & - "If true, turns on the [CVMix] KPP scheme of Large et al., 1994,\n"// & - "to calculate diffusivities and non-local transport in the OBL.", & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& + "to calculate diffusivities and non-local transport in the OBL.", & default=.false., do_not_log=.true.) CS%use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) @@ -2853,7 +2793,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (CS%bulkmixedlayer) then call get_param(param_file, mdl, "ML_MIX_FIRST", CS%ML_mix_first, & - "The fraction of the mixed layer mixing that is applied \n"//& + "The fraction of the mixed layer mixing that is applied "//& "before interior diapycnal mixing. 0 by default.", & units="nondim", default=0.0) call get_param(param_file, mdl, "NKBL", CS%nkbl, default=2, do_not_log=.true.) @@ -2867,13 +2807,13 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%use_geothermal = .false. endif call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & - "If true, use the code that advances a separate set of \n"//& + "If true, use the code that advances a separate set of "//& "equations for the internal tide energy density.", default=.false.) CS%nMode = 1 if (CS%use_int_tides) then ! SET NUMBER OF MODES TO CONSIDER call get_param(param_file, mdl, "INTERNAL_TIDE_MODES", CS%nMode, & - "The number of distinct internal tide modes \n"//& + "The number of distinct internal tide modes "//& "that will be calculated.", default=1, do_not_log=.true.) ! The following parameters are used in testing the internal tide code. @@ -2902,19 +2842,18 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call get_param(param_file, mdl, "MASSLESS_MATCH_TARGETS", & CS%massless_match_targets, & - "If true, the temperature and salinity of massless layers \n"//& - "are kept consistent with their target densities. \n"//& - "Otherwise the properties of massless layers evolve \n"//& + "If true, the temperature and salinity of massless layers "//& + "are kept consistent with their target densities. "//& + "Otherwise the properties of massless layers evolve "//& "diffusively to match massive neighboring layers.", & default=.true.) call get_param(param_file, mdl, "AGGREGATE_FW_FORCING", CS%aggregate_FW_forcing, & - "If true, the net incoming and outgoing fresh water fluxes are combined\n"//& - "and applied as either incoming or outgoing depending on the sign of the net.\n"//& - "If false, the net incoming fresh water flux is added to the model and\n"//& - "thereafter the net outgoing is removed from the updated state."//& - "into the first non-vanished layer for which the column remains stable", & - default=.true.) + "If true, the net incoming and outgoing fresh water fluxes are combined "//& + "and applied as either incoming or outgoing depending on the sign of the net. "//& + "If false, the net incoming fresh water flux is added to the model and "//& + "thereafter the net outgoing is removed from the topmost non-vanished "//& + "layers of the updated state.", default=.true.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & @@ -2926,36 +2865,36 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call get_param(param_file, mdl, "DEBUG_ENERGY_REQ", CS%debug_energy_req, & "If true, debug the energy requirements.", default=.false., do_not_log=.true.) call get_param(param_file, mdl, "MIX_BOUNDARY_TRACERS", CS%mix_boundary_tracers, & - "If true, mix the passive tracers in massless layers at \n"//& - "the bottom into the interior as though a diffusivity of \n"//& + "If true, mix the passive tracers in massless layers at "//& + "the bottom into the interior as though a diffusivity of "//& "KD_MIN_TR were operating.", default=.true.) if (CS%mix_boundary_tracers) then call get_param(param_file, mdl, "KD", Kd, fail_if_missing=.true.) call get_param(param_file, mdl, "KD_MIN_TR", CS%Kd_min_tr, & - "A minimal diffusivity that should always be applied to \n"//& - "tracers, especially in massless layers near the bottom. \n"//& + "A minimal diffusivity that should always be applied to "//& + "tracers, especially in massless layers near the bottom. "//& "The default is 0.1*KD.", units="m2 s-1", default=0.1*Kd, scale=US%m_to_Z**2) call get_param(param_file, mdl, "KD_BBL_TR", CS%Kd_BBL_tr, & - "A bottom boundary layer tracer diffusivity that will \n"//& - "allow for explicitly specified bottom fluxes. The \n"//& - "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) \n"//& + "A bottom boundary layer tracer diffusivity that will "//& + "allow for explicitly specified bottom fluxes. The "//& + "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) "//& "over the same distance.", units="m2 s-1", default=0., scale=US%m_to_Z**2) endif call get_param(param_file, mdl, "TRACER_TRIDIAG", CS%tracer_tridiag, & - "If true, use the passive tracer tridiagonal solver for T and S\n", & + "If true, use the passive tracer tridiagonal solver for T and S", & default=.false.) call get_param(param_file, mdl, "MINIMUM_FORCING_DEPTH", CS%minimum_forcing_depth, & - "The smallest depth over which forcing can be applied. This\n"//& - "only takes effect when near-surface layers become thin\n"//& - "relative to this scale, in which case the forcing tendencies\n"//& + "The smallest depth over which forcing can be applied. This "//& + "only takes effect when near-surface layers become thin "//& + "relative to this scale, in which case the forcing tendencies "//& "scaled down by distributing the forcing over this depth scale.", & units="m", default=0.001) call get_param(param_file, mdl, "EVAP_CFL_LIMIT", CS%evap_CFL_limit, & - "The largest fraction of a layer than can be lost to forcing\n"//& - "(e.g. evaporation, sea-ice formation) in one time-step. The unused\n"//& + "The largest fraction of a layer than can be lost to forcing "//& + "(e.g. evaporation, sea-ice formation) in one time-step. The unused "//& "mass loss is passed down through the column.", & units="nondim", default=0.8) @@ -2999,60 +2938,43 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di enddo endif - CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff",diag%axesTi, & - Time, "Diffusive diapycnal temperature flux across interfaces", & - "degC m s-1") - CS%id_Tadv = register_diag_field('ocean_model',"Tflx_dia_adv",diag%axesTi, & - Time, "Advective diapycnal temperature flux across interfaces", & - "degC m s-1") - CS%id_Sdif = register_diag_field('ocean_model',"Sflx_dia_diff",diag%axesTi, & - Time, "Diffusive diapycnal salnity flux across interfaces", & - "psu m s-1") - CS%id_Sadv = register_diag_field('ocean_model',"Sflx_dia_adv",diag%axesTi, & - Time, "Advective diapycnal salnity flux across interfaces", & - "psu m s-1") - CS%id_MLD_003 = register_diag_field('ocean_model', 'MLD_003', diag%axesT1, Time, & - 'Mixed layer depth (delta rho = 0.03)', 'm', conversion=US%Z_to_m, & - cmor_field_name='mlotst', cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & - cmor_standard_name='ocean_mixed_layer_thickness_defined_by_sigma_t') - CS%id_mlotstsq = register_diag_field('ocean_model','mlotstsq',diag%axesT1, Time, & - long_name='Square of Ocean Mixed Layer Thickness Defined by Sigma T', & - standard_name='square_of_ocean_mixed_layer_thickness_defined_by_sigma_t', & - units='m2', conversion=US%Z_to_m**2) - CS%id_MLD_0125 = register_diag_field('ocean_model','MLD_0125',diag%axesT1,Time, & - 'Mixed layer depth (delta rho = 0.125)', 'm', conversion=US%Z_to_m) - CS%id_subMLN2 = register_diag_field('ocean_model','subML_N2',diag%axesT1,Time, & - 'Squared buoyancy frequency below mixed layer', 's-2') - CS%id_MLD_user = register_diag_field('ocean_model','MLD_user',diag%axesT1,Time, & - 'Mixed layer depth (used defined)', 'm', conversion=US%Z_to_m) + if (use_temperature) then + CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff",diag%axesTi, & + Time, "Diffusive diapycnal temperature flux across interfaces", & + "degC m s-1") + CS%id_Tadv = register_diag_field('ocean_model',"Tflx_dia_adv",diag%axesTi, & + Time, "Advective diapycnal temperature flux across interfaces", & + "degC m s-1") + CS%id_Sdif = register_diag_field('ocean_model',"Sflx_dia_diff",diag%axesTi, & + Time, "Diffusive diapycnal salnity flux across interfaces", & + "psu m s-1") + CS%id_Sadv = register_diag_field('ocean_model',"Sflx_dia_adv",diag%axesTi, & + Time, "Advective diapycnal salnity flux across interfaces", & + "psu m s-1") + CS%id_MLD_003 = register_diag_field('ocean_model', 'MLD_003', diag%axesT1, Time, & + 'Mixed layer depth (delta rho = 0.03)', 'm', conversion=US%Z_to_m, & + cmor_field_name='mlotst', cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & + cmor_standard_name='ocean_mixed_layer_thickness_defined_by_sigma_t') + CS%id_mlotstsq = register_diag_field('ocean_model','mlotstsq',diag%axesT1, Time, & + long_name='Square of Ocean Mixed Layer Thickness Defined by Sigma T', & + standard_name='square_of_ocean_mixed_layer_thickness_defined_by_sigma_t', & + units='m2', conversion=US%Z_to_m**2) + CS%id_MLD_0125 = register_diag_field('ocean_model','MLD_0125',diag%axesT1,Time, & + 'Mixed layer depth (delta rho = 0.125)', 'm', conversion=US%Z_to_m) + CS%id_subMLN2 = register_diag_field('ocean_model','subML_N2',diag%axesT1,Time, & + 'Squared buoyancy frequency below mixed layer', 's-2') + CS%id_MLD_user = register_diag_field('ocean_model','MLD_user',diag%axesT1,Time, & + 'Mixed layer depth (used defined)', 'm', conversion=US%Z_to_m) + endif call get_param(param_file, mdl, "DIAG_MLD_DENSITY_DIFF", CS%MLDdensityDifference, & - "The density difference used to determine a diagnostic mixed\n"//& - "layer depth, MLD_user, following the definition of Levitus 1982. \n"//& - "The MLD is the depth at which the density is larger than the\n"//& + "The density difference used to determine a diagnostic mixed "//& + "layer depth, MLD_user, following the definition of Levitus 1982. "//& + "The MLD is the depth at which the density is larger than the "//& "surface density by the specified amount.", units='kg/m3', default=0.1) - - ! diagnostics making use of the z-gridding code - if (associated(diag_to_Z_CSp)) then - vd = var_desc("Kd_interface", "m2 s-1", & - "Diapycnal diffusivity at interfaces, interpolated to z", z_grid='z') - CS%id_Kd_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) - vd = var_desc("Tflx_dia_diff", "degC m s-1", & - "Diffusive diapycnal temperature flux across interfaces, interpolated to z", & - z_grid='z') - CS%id_Tdif_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) - vd = var_desc("Tflx_dia_adv", "degC m s-1", & - "Advective diapycnal temperature flux across interfaces, interpolated to z", & - z_grid='z') - CS%id_Tadv_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) - vd = var_desc("Sflx_dia_diff", "psu m s-1", & - "Diffusive diapycnal salinity flux across interfaces, interpolated to z", & - z_grid='z') - CS%id_Sdif_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) - vd = var_desc("Sflx_dia_adv", "psu m s-1", & - "Advective diapycnal salinity flux across interfaces, interpolated to z", & - z_grid='z') - CS%id_Sadv_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) - endif + call get_param(param_file, mdl, "DIAG_DEPTH_SUBML_N2", CS%dz_subML_N2, & + "The distance over which to calculate a diagnostic of the "//& + "stratification at the base of the mixed layer.", & + units='m', default=50.0, scale=US%m_to_Z) if (CS%id_dudt_dia > 0) call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) if (CS%id_dvdt_dia > 0) call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) @@ -3074,9 +2996,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif - !call set_diffusivity_init(Time, G, param_file, diag, CS%set_diff_CSp, diag_to_Z_CSp, CS%int_tide_CSp) + !call set_diffusivity_init(Time, G, param_file, diag, CS%set_diff_CSp, CS%int_tide_CSp) CS%id_Kd_interface = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & - 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z_to_m**2) + 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) if (CS%use_energetic_PBL) then CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z_to_m**2) @@ -3113,7 +3035,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif call get_param(param_file, mdl, "SALT_REJECT_BELOW_ML", CS%salt_reject_below_ML, & - "If true, place salt from brine rejection below the mixed layer,\n"// & + "If true, place salt from brine rejection below the mixed layer, "// & "into the first non-vanished layer for which the column remains stable", & default=.false.) @@ -3289,7 +3211,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif ! CS%use_tidal_mixing is set to True if an internal tidal dissipation scheme is to be used. - CS%use_tidal_mixing = tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_CSp, & + CS%use_tidal_mixing = tidal_mixing_init(Time, G, GV, US, param_file, diag, & CS%tidal_mixing_CSp) ! CS%use_CVMix_conv is set to True if CVMix convection will be used, otherwise @@ -3310,10 +3232,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif ! initialize module for setting diffusivities - call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, diag_to_Z_CSp, & + call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, & CS%int_tide_CSp, CS%tidal_mixing_CSp, CS%halo_TS_diff) - ! set up the clocks for this module id_clock_entrain = cpu_clock_id('(Ocean diabatic entrain)', grain=CLOCK_MODULE) if (CS%bulkmixedlayer) & diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 5c9d06e96f..3d9fb3c6c7 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -1291,14 +1291,14 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENERGY_REQ_KH_SCALING", CS%test_Kh_scaling, & - "A scaling factor for the diapycnal diffusivity used in \n"//& + "A scaling factor for the diapycnal diffusivity used in "//& "testing the energy requirements.", default=1.0, units="nondim") call get_param(param_file, mdl, "ENERGY_REQ_COL_HT_SCALING", CS%ColHt_scaling, & - "A scaling factor for the column height change correction \n"//& + "A scaling factor for the column height change correction "//& "used in testing the energy requirements.", default=1.0, units="nondim") call get_param(param_file, mdl, "ENERGY_REQ_USE_TEST_PROFILE", & CS%use_test_Kh_profile, & - "If true, use the internal test diffusivity profile in \n"//& + "If true, use the internal test diffusivity profile in "//& "place of any that might be passed in as an argument.", default=.false.) CS%id_ERt = register_diag_field('ocean_model', 'EnReqTest_ERt', diag%axesZi, Time, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index b171570f8e..e4b294d3d8 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -58,6 +58,11 @@ module MOM_energetic_PBL !! energy is converted to a turbulent velocity, relative to !! mechanically forced turbulent kinetic energy [nondim]. !! Making this larger increases the diffusivity. + integer :: vstar_mode !< An integer marking the chosen method for finding vstar. + !! vstar = 0 is the original (TKE_remaining)^1/3 + !! vstar = 1 is the version described by Reichl and Hallberg, 2018 + real :: vstar_surf_fac !< If (vstar == 1) this is the proportionality coefficient between + !! ustar and the surface mechanical contribution to vstar real :: vstar_scale_fac !< An overall nondimensional scaling factor for vstar times a unit !! conversion factor. Making this larger increases the diffusivity. real :: Ekman_scale_coef !< A nondimensional scaling factor controlling the inhibition of the @@ -81,6 +86,7 @@ module MOM_energetic_PBL !! local stratification. This dissipation is applied to the available !! TKE which includes both that generated at the surface and that !! generated at depth. + !MSTAR related options real :: MSTAR_CAP !< Since MSTAR is restoring undissipated energy to mixing, !! there must be a cap on how large it can be. This !! is definitely a function of latitude (Ekman limit), @@ -92,9 +98,21 @@ module MOM_energetic_PBL real :: MSTAR_XINT_UP !< Similar but for transition to asymptotic cap. real :: MSTAR_AT_XINT !< Intercept value of MSTAR at value where function !! changes to linear transition. - integer :: LT_ENHANCE_FORM !< Integer for Enhancement functional form (various options) - real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancment - real :: LT_ENHANCE_EXP !< Exponent in fit for Langmuir Enhancement + real :: RH18_mst_cN1 !< MSTAR_N coefficient 1 (outter-most coefficient for fit). + !! Value of 0.275 in RH18. Increasing this + !! coefficient increases mechanical mixing for all values of Hf/ust, + !! but is most effective at low values (weakly developed OSBLs). + real :: RH18_mst_cN2 !< MSTAR_N coefficient 2 (coefficient outside of exponential decay). + !! Value of 8.0 in RH18. Increasing this coefficient increases MSTAR + !! for all values of HF/ust, with a consistent affect across + !! a wide range of Hf/ust. + real :: RH18_mst_cN3 !< MSTAR_N coefficient 3 (exponential decay coefficient). Value of + !! -5.0 in RH18. Increasing this increases how quickly the value + !! of MSTAR decreases as Hf/ust increases. + real :: RH18_mst_cS1 !< MSTAR_S coefficient for RH18 in stabilizing limit. + !! Value of 0.2 in RH18. + real :: RH18_mst_cS2 !< MSTAR_S exponent for RH18 in stabilizing limit. + !! Value of 0.4 in RH18. real :: MSTAR_N = -2. !< Exponent in decay at negative and positive limits of MLD_over_STAB real :: MSTAR_A !< Coefficients of expressions for mstar in asymptotic limits, computed !! to match the function value and slope at both ends of the linear fit @@ -104,6 +122,14 @@ module MOM_energetic_PBL real :: MSTAR_B2 !< Coefficients of expressions for mstar in asymptotic limits. real :: C_EK = 0.17 !< MSTAR Coefficient in rotation limit for mstar_mode=2 real :: MSTAR_COEF = 0.3 !< MSTAR coefficient in rotation/stabilizing balance for mstar_mode=2 + !Langmuir turbulence related parameters + integer :: LT_ENHANCE_FORM !< Integer for Enhancement functional form (various options) + real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancment + real :: LT_ENHANCE_EXP !< Exponent in fit for Langmuir Enhancement + logical :: LT_ENH_K_R16 !< Logical to toggle enhanced local mixing coefficient due to Langmuir + !! following Reichl et al., 2016. This setting is unverified + !! outside of strongly shear-forced shear turbulence and therefore + !! it is not recommended to employ this option for general use. real :: LaC_MLDoEK !< Coefficient for Langmuir number modification based on the ratio of !! the mixed layer depth over the Ekman depth. real :: LaC_MLDoOB_stab !< Coefficient for Langmuir number modification based on the ratio of @@ -124,6 +150,7 @@ module MOM_energetic_PBL !! layer depth to the Obukhov depth integer :: EKMAN_o_OBUKHOV=2 !< The value of MSTAR_MODE to base mstar on the ratio of the Ekman !! layer depth to the Obukhov depth + integer :: MSTAR_RH18 = 3 !< The value of MSTAR_MODE to base mstar off of RH18 logical :: MSTAR_FLATCAP=.true. !< Set false to use asymptotic mstar cap. logical :: TKE_diagnostics = .false. !< If true, diagnostics of the TKE budget are being calculated. logical :: Use_LT = .false. !< Flag for using LT in Energy calculation @@ -495,6 +522,13 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real :: MSTAR_LT ! The added mstar contribution due to Langmuir turbulence real :: MSTAR_Conv_Adj ! Adjustment made to mstar due to convection reducing mechanical mixing. real :: MSTAR_STAB, MSTAR_ROT ! Mstar in each limit, max is used. + real :: Surface_Scale ! Surface decay scale for vstar + real :: K_Enhancement ! A local enhancement of K, perhaps due to Langmuir turbulence + ! For LT_ENH_K_R16 + real :: Shape_Function ! The shape function of the enhancement + real, parameter :: Max_Shape_Function = 0.148148 ! The max value of the shape function of the enhancement + real, parameter :: Max_K_Enhancement = 2.25 ! The max value of the enhancement + !-End for LT_ENH_K_R16 logical :: debug=.false. ! Change this hard-coded value for debugging. ! The following arrays are used only for debugging purposes. @@ -784,9 +818,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! mstar_ROT = CS%C_EK * log(U_star / (absf(i) * MLD_guess)) ! Here 1.25 is .5/von Karman, which gives the Obukhov limit. MSTAR_MIX = max(mstar_STAB, min(1.25, mstar_ROT)) - if (CS%MSTAR_CAP > 0.0) MSTAR_MIX = min(CS%MSTAR_CAP, MSTAR_MIX) - endif!mstar_mode==1 or ==2 + elseif (CS%MSTAR_MODE.eq.CS%MSTAR_RH18) then + MSTAR_ROT = CS%RH18_MST_CN1 * ( 1.0 - ( 1.+CS%RH18_MST_CN2 * & + exp( CS%RH18_MST_CN3 * MLD_GUESS * absf(i) / u_star) )**-1.0 ) + MSTAR_STAB = CS%RH18_MST_CS1 * (bf_stable**2*MLD_GUESS & + / ( u_star**5 * absf(i) ) ) **CS%RH18_MST_CS2 + MSTAR_MIX = MSTAR_ROT + MSTAR_STAB + endif!mstar_mode==1 or ==2 or ==3 ! Adjustment for unstable buoyancy flux. ! Convection reduces mechanical mixing because there ! is less density gradient to mix. (Statically unstable near surface) @@ -901,7 +940,6 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS mech_TKE_k(i,1) = mech_TKE(i) ; conv_PErel_k(i,1) = conv_PErel(i) nstar_k(:) = 0.0 ; nstar_k(1) = CS%nstar ; num_itts(:) = -1 endif - do K=2,nz ! Apply dissipation to the TKE, here applied as an exponential decay ! due to 3-d turbulent energy being lost to inefficient rotational modes. @@ -1070,7 +1108,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS h_tt = htot(i) + h_tt_min TKE_here = mech_TKE(i) + CS%wstar_ustar_coef*conv_PErel(i) if (TKE_here > 0.0) then - vstar = CS%vstar_scale_fac * (I_dtrho*TKE_here)**C1_3 + if (CS%vstar_mode==0) then + vstar = CS%vstar_scale_fac * (I_dtrho*TKE_here)**C1_3 + elseif (CS%vstar_mode==1) then + Surface_Scale = max(0.05,1.-htot(i)/MLD_guess) + vstar = CS%vstar_scale_fac * (CS%vstar_surf_fac*U_Star + & + (CS%wstar_ustar_coef*conv_PErel(i)*I_dtrho)**C1_3)* & + Surface_Scale + endif hbs_here = GV%H_to_Z * min(hb_hs(i,K), MixLen_shape(K)) Mixing_Length_Used(k) = MAX(CS%min_mix_len, ((h_tt*hbs_here)*vstar) / & ((CS%Ekman_scale_coef * absf(i)) * (h_tt*hbs_here) + vstar)) @@ -1082,6 +1127,12 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS else Kd_guess0 = vstar * vonKar * Mixing_Length_Used(k) endif + ! Compute the local enhnacement of K (perhaps due to Langmuir) + if (CS%LT_ENH_K_R16) then + Shape_Function = htot(i)/MLD_guess*(1.-htot(i)/MLD_guess)**2 + K_Enhancement = ( min( Max_K_Enhancement,1.+1./La ) - 1. ) + Kd_guess0 = Kd_guess0 * Shape_Function / Max_Shape_Function + endif else vstar = 0.0 ; Kd_guess0 = 0.0 endif @@ -1122,7 +1173,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Does MKE_src need to be included in the calculation of vstar here? TKE_here = mech_TKE(i) + CS%wstar_ustar_coef*(conv_PErel(i)-PE_chg_max) if (TKE_here > 0.0) then - vstar = CS%vstar_scale_fac * (I_dtrho*TKE_here)**C1_3 + if (CS%vstar_mode==0) then + vstar = CS%vstar_scale_fac * (I_dtrho*TKE_here)**C1_3 + elseif (CS%vstar_mode==1) then + Surface_Scale = max(0.05,1.-htot(i)/MLD_guess) + vstar = cs%vstar_scale_fac * (CS%vstar_surf_fac*U_Star + & + (CS%wstar_ustar_coef*conv_PErel(i)*I_dtrho)**C1_3)* & + Surface_Scale + endif hbs_here = GV%H_to_Z * min(hb_hs(i,K), MixLen_shape(K)) Mixing_Length_Used(k) = max(CS%min_mix_len,((h_tt*hbs_here)*vstar) / & ((CS%Ekman_scale_coef * absf(i)) * (h_tt*hbs_here) + vstar)) @@ -1134,6 +1192,12 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS else Kd(i,k) = vstar * vonKar * Mixing_Length_Used(k) endif + ! Compute the local enhnacement of K (perhaps due to Langmuir) + if (CS%LT_ENH_K_R16) then + Shape_Function = htot(i)/MLD_guess*(1.-htot(i)/MLD_guess)**2 + K_Enhancement = ( min( Max_K_Enhancement,1.+1./La ) - 1. ) + Kd(i,k) = Kd(i,K) * Shape_Function / Max_Shape_Function + endif else vstar = 0.0 ; Kd(i,k) = 0.0 endif @@ -2045,71 +2109,99 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "An integer switch for how to compute MSTAR. \n"//& " 0 for constant MSTAR\n"//& " 1 for MSTAR w/ MLD in stabilizing limit\n"//& - " 2 for MSTAR w/ L_E/L_O in stabilizing limit.",& + " 2 for MSTAR w/ L_E/L_O in stabilizing limit\n"//& + " 3 for MSTAR as in RH18.",& "units=nondim",default=0) call get_param(param_file, mdl, "MSTAR", CS%mstar, & - "The ratio of the friction velocity cubed to the TKE \n"//& + "The ratio of the friction velocity cubed to the TKE "//& "input to the mixed layer.", "units=nondim", default=1.2) call get_param(param_file, mdl, "MIX_LEN_EXPONENT", CS%MixLenExponent, & - "The exponent applied to the ratio of the distance to the MLD \n"//& + "The exponent applied to the ratio of the distance to the MLD "//& "and the MLD depth which determines the shape of the mixing length.",& "units=nondim", default=2.0) call get_param(param_file, mdl, "MSTAR_CAP", CS%mstar_cap, & - "Maximum value of mstar allowed in model if non-negative\n"//& + "Maximum value of mstar allowed in model if non-negative "//& "(used if MSTAR_MODE>0).",& "units=nondim", default=-1.0) call get_param(param_file, mdl, "MSTAR_CONV_ADJ", CS%cnv_mst_fac, & - "Factor used for reducing mstar during convection \n"//& - " due to reduction of stable density gradient.",& + "Factor used for reducing mstar during convection "//& + "due to reduction of stable density gradient.",& "units=nondim", default=0.0) call get_param(param_file, mdl, "MSTAR_SLOPE", CS%mstar_slope, & - "The slope of the linear relationship between mstar \n"//& + "The slope of the linear relationship between mstar "//& "and the length scale ratio (used if MSTAR_MODE=1).",& "units=nondim", default=0.85) call get_param(param_file, mdl, "MSTAR_XINT", CS%mstar_xint, & - "The value of the length scale ratio where the mstar \n"//& + "The value of the length scale ratio where the mstar "//& "is linear above (used if MSTAR_MODE=1).",& "units=nondim", default=-0.3) call get_param(param_file, mdl, "MSTAR_AT_XINT", CS%mstar_at_xint, & - "The value of mstar at MSTAR_XINT \n"//& + "The value of mstar at MSTAR_XINT "//& "(used if MSTAR_MODE=1).",& "units=nondim", default=0.095) call get_param(param_file, mdl, "MSTAR_FLATCAP", CS%MSTAR_FLATCAP, & - "Set false to use asymptotic cap, defaults to true.\n"//& + "Set false to use asymptotic cap, defaults to true. "//& "(used only if MSTAR_MODE=1)"& ,"units=nondim",default=.true.) call get_param(param_file, mdl, "MSTAR2_COEF1", CS%MSTAR_COEF, & - "Coefficient in computing mstar when rotation and \n"//& - " stabilizing effects are both important (used if MSTAR_MODE=2)"& + "Coefficient in computing mstar when rotation and "//& + "stabilizing effects are both important (used if MSTAR_MODE=2)"& ,"units=nondim",default=0.3) call get_param(param_file, mdl, "MSTAR2_COEF2", CS%C_EK, & - "Coefficient in computing mstar when only rotation limits \n"//& - " the total mixing. (used only if MSTAR_MODE=2)"& + "Coefficient in computing mstar when only rotation limits "//& + "the total mixing. (used only if MSTAR_MODE=2)"& ,"units=nondim",default=0.085) + call get_param(param_file, mdl, "RH18_MST_CN1", CS%RH18_MST_CN1,& + "MSTAR_N coefficient 1 (outter-most coefficient for fit). \n"//& + " The value of 0.275 is given in RH18. Increasing this \n"//& + "coefficient increases MSTAR for all values of Hf/ust, but more \n"//& + "effectively at low values (weakly developed OSBLs).",& + units="nondim", default=0.275) + call get_param(param_file, mdl, "RH18_MST_CN2", CS%RH18_MST_CN2,& + "MSTAR_N coefficient 2 (coefficient outside of exponential decay). \n"//& + "The value of 8.0 is given in RH18. Increasing this coefficient \n"//& + "increases MSTAR for all values of HF/ust, with a much more even \n"//& + "effect across a wide range of Hf/ust than CN1.",& + units="nondim",default=8.0) + call get_param(param_file, mdl, "RH18_MST_CN3", CS%RH18_MST_CN3,& + "MSTAR_N coefficient 3 (exponential decay coefficient). \n"//& + "The value of -5.0 is given in RH18. Increasing this increases how \n"//& + "quickly the value of MSTAR decreases as Hf/ust increases.",& + units="nondim",default=-5.0) + call get_param(param_file, mdl, "RH18_MST_CS1", CS%RH18_MST_CS1,& + "MSTAR_S coefficient for RH18 in stabilizing limit. \n"//& + "The value of 0.2 is given in RH18 and increasing it increases \n"//& + "MSTAR in the presence of a stabilizing surface buoyancy flux.",& + units="nondim",default=0.2) + call get_param(param_file, mdl, "RH18_MST_CS2", CS%RH18_MST_CS2,& + "MSTAR_S exponent for RH18 in stabilizing limit. \n"//& + "The value of 0.4 is given in RH18 and increasing it increases MSTAR \n"//& + "exponentially in the presence of a stabilizing surface buoyancy flux.",& + Units="nondim",default=0.4) call get_param(param_file, mdl, "NSTAR", CS%nstar, & - "The portion of the buoyant potential energy imparted by \n"//& - "surface fluxes that is available to drive entrainment \n"//& + "The portion of the buoyant potential energy imparted by "//& + "surface fluxes that is available to drive entrainment "//& "at the base of mixed layer when that energy is positive.", & units="nondim", default=0.2) call get_param(param_file, mdl, "MKE_TO_TKE_EFFIC", CS%MKE_to_TKE_effic, & - "The efficiency with which mean kinetic energy released \n"//& - "by mechanically forced entrainment of the mixed layer \n"//& + "The efficiency with which mean kinetic energy released "//& + "by mechanically forced entrainment of the mixed layer "//& "is converted to turbulent kinetic energy.", units="nondim", & default=0.0) call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & - "TKE_DECAY relates the vertical rate of decay of the \n"//& - "TKE available for mechanical entrainment to the natural \n"//& + "TKE_DECAY relates the vertical rate of decay of the "//& + "TKE available for mechanical entrainment to the natural "//& "Ekman depth.", units="nondim", default=2.5) ! call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & -! "The minimum mixed layer depth if the mixed layer depth \n"//& +! "The minimum mixed layer depth if the mixed layer depth "//& ! "is determined dynamically.", units="m", default=0.0) call get_param(param_file, mdl, "OMEGA",CS%omega, & "The rotation rate of the earth.", units="s-1", & default=7.2921e-5) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & - "If true, use the absolute rotation rate instead of the \n"//& - "vertical component of rotation when setting the decay \n"// & + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "// & "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then @@ -2117,51 +2209,66 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & - "When setting the decay scale for turbulence, use this \n"// & - "fraction of the absolute rotation rate blended with the \n"//& + "When setting the decay scale for turbulence, use this "// & + "fraction of the absolute rotation rate blended with the "//& "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & units="nondim", default=omega_frac_dflt) + call get_param(param_file, mdl, "VSTAR_MODE", CS%vstar_mode, & + "An integer switch for how to compute VSTAR. \n"//& + " 0 for old vstar (TKE Remaining)^(1/3)\n"//& + " 1 for vstar from u* and w* (see Reichl & Hallberg 2018).",& + "units=nondim",default=0) call get_param(param_file, mdl, "WSTAR_USTAR_COEF", CS%wstar_ustar_coef, & - "A ratio relating the efficiency with which convectively \n"//& - "released energy is converted to a turbulent velocity, \n"// & - "relative to mechanically forced TKE. Making this larger \n"//& + "A ratio relating the efficiency with which convectively "//& + "released energy is converted to a turbulent velocity, "// & + "relative to mechanically forced TKE. Making this larger "//& "increases the BL diffusivity", units="nondim", default=1.0) call get_param(param_file, mdl, "VSTAR_SCALE_FACTOR", CS%vstar_scale_fac, & - "An overall nondimensional scaling factor for v*. \n"// & + "An overall nondimensional scaling factor for v*. "// & "Making this larger decreases the PBL diffusivity.", & units="nondim", default=1.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "VSTAR_SURF_FAC", CS%vstar_surf_fac,& + "The proportionality times ustar to set vstar to at the surface.",& + "units=nondim", default=1.2) + call get_param(param_file, mdl, "LT_ENHANCE_K_R16",CS%LT_ENH_K_R16, & + "Logical flag to toggle on enhancing mixing coefficient in\n"//& + "boundary layer due to Langmuir turbulence following Reichl\n"//& + "et al., 2016. \n"//& + "This approach is not recommended for use, as it is based\n"//& + "on a hurricane LES configuration and not known if it is general.",& + units="nondim",default=.false.) call get_param(param_file, mdl, "EKMAN_SCALE_COEF", CS%Ekman_scale_coef, & - "A nondimensional scaling factor controlling the inhibition \n"// & - "of the diffusive length scale by rotation. Making this larger \n"//& + "A nondimensional scaling factor controlling the inhibition "// & + "of the diffusive length scale by rotation. Making this larger "//& "decreases the PBL diffusivity.", units="nondim", default=1.0) call get_param(param_file, mdl, "USE_MLD_ITERATION", CS%USE_MLD_ITERATION, & - "A logical that specifies whether or not to use the \n"// & - "distance to the bottom of the actively turblent boundary \n"//& + "A logical that specifies whether or not to use the "// & + "distance to the bottom of the actively turbulent boundary "//& "layer to help set the EPBL length scale.", default=.false.) call get_param(param_file, mdl, "ORIG_MLD_ITERATION", CS%ORIG_MLD_ITERATION, & - "A logical that specifies whether or not to use the \n"// & - "old method for determining MLD depth in iteration, which \n"//& + "A logical that specifies whether or not to use the "// & + "old method for determining MLD depth in iteration, which "//& "is limited to resolution.", default=.true.) call get_param(param_file, mdl, "MLD_ITERATION_GUESS", CS%MLD_ITERATION_GUESS, & - "A logical that specifies whether or not to use the \n"// & - "previous timestep MLD as a first guess in the MLD iteration.\n"// & + "A logical that specifies whether or not to use the "// & + "previous timestep MLD as a first guess in the MLD iteration. "// & "The default is false to facilitate reproducibility.", default=.false.) call get_param(param_file, mdl, "EPBL_MLD_TOLERANCE", CS%MLD_tol, & - "The tolerance for the iteratively determined mixed \n"// & + "The tolerance for the iteratively determined mixed "// & "layer depth. This is only used with USE_MLD_ITERATION.", & units="meter", default=1.0, scale=US%m_to_Z) call get_param(param_file, mdl, "EPBL_MIN_MIX_LEN", CS%min_mix_len, & - "The minimum mixing length scale that will be used \n"//& + "The minimum mixing length scale that will be used "//& "by ePBL. The default (0) does not set a minimum.", & units="meter", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "EPBL_ORIGINAL_PE_CALC", CS%orig_PE_calc, & - "If true, the ePBL code uses the original form of the \n"// & - "potential energy change code. Otherwise, the newer \n"// & - "version that can work with successive increments to the \n"// & + "If true, the ePBL code uses the original form of the "// & + "potential energy change code. Otherwise, the newer "// & + "version that can work with successive increments to the "// & "diffusivity in upward or downward passes is used.", default=.true.) call get_param(param_file, mdl, "EPBL_TRANSITION_SCALE", CS%transLay_scale, & - "A scale for the mixing length in the transition layer \n"// & - "at the edge of the boundary layer as a fraction of the \n"//& + "A scale for the mixing length in the transition layer "// & + "at the edge of the boundary layer as a fraction of the "//& "boundary layer thickness. The default is 0.1.", & units="nondim", default=0.1) if ( CS%USE_MLD_ITERATION .and. abs(CS%transLay_scale-0.5) >= 0.5) then @@ -2169,19 +2276,18 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "EPBL_TRANSITION should be greater than 0 and less than 1.") endif call get_param(param_file, mdl, "N2_DISSIPATION_POS", CS%N2_Dissipation_Scale_Pos, & - "A scale for the dissipation of TKE due to stratification \n"// & - "in the boundary layer, applied when local stratification \n"// & + "A scale for the dissipation of TKE due to stratification "// & + "in the boundary layer, applied when local stratification "// & "is positive. The default is 0, but should probably be ~0.4.", & units="nondim", default=0.0) call get_param(param_file, mdl, "N2_DISSIPATION_NEG", CS%N2_Dissipation_Scale_Neg,& - "A scale for the dissipation of TKE due to stratification \n"// & - "in the boundary layer, applied when local stratification \n"// & + "A scale for the dissipation of TKE due to stratification "// & + "in the boundary layer, applied when local stratification "// & "is negative. The default is 0, but should probably be ~1.", & units="nondim", default=0.0) call get_param(param_file, mdl, "USE_LA_LI2016", USE_LA_Windsea, & - "A logical to use the Li et al. 2016 (submitted) formula to \n"//& - " determine the Langmuir number.", & - units="nondim", default=.false.) + "A logical to use the Li et al. 2016 (submitted) formula to "//& + "determine the Langmuir number.", units="nondim", default=.false.) ! Note this can be activated in other ways, but this preserves the old method. if (use_la_windsea) then CS%USE_LT = .true. @@ -2206,30 +2312,30 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "Exponent for Langmuir enhancement if LT_ENHANCE > 1", & units="nondim", default=-1.33) call get_param(param_file, mdl, "LT_MOD_LAC1", CS%LaC_MLDoEK, & - "Coefficient for modification of Langmuir number due to\n"//& - " MLD approaching Ekman depth if LT_ENHANCE=2.", & + "Coefficient for modification of Langmuir number due to "//& + "MLD approaching Ekman depth if LT_ENHANCE=2.", & units="nondim", default=-0.87) call get_param(param_file, mdl, "LT_MOD_LAC2", CS%LaC_MLDoOB_stab, & - "Coefficient for modification of Langmuir number due to\n"// & - " MLD approaching stable Obukhov depth if LT_ENHANCE=2.", & + "Coefficient for modification of Langmuir number due to "// & + "MLD approaching stable Obukhov depth if LT_ENHANCE=2.", & units="nondim", default=0.0) call get_param(param_file, mdl, "LT_MOD_LAC3", CS%LaC_MLDoOB_un, & - "Coefficient for modification of Langmuir number due to\n"//& - " MLD approaching unstable Obukhov depth if LT_ENHANCE=2.", & + "Coefficient for modification of Langmuir number due to "//& + "MLD approaching unstable Obukhov depth if LT_ENHANCE=2.", & units="nondim", default=0.0) call get_param(param_file, mdl, "LT_MOD_LAC4", CS%Lac_EKoOB_stab, & - "Coefficient for modification of Langmuir number due to\n"// & - " ratio of Ekman to stable Obukhov depth if LT_ENHANCE=2.", & + "Coefficient for modification of Langmuir number due to "// & + "ratio of Ekman to stable Obukhov depth if LT_ENHANCE=2.", & units="nondim", default=0.95) call get_param(param_file, mdl, "LT_MOD_LAC5", CS%Lac_EKoOB_un, & - "Coefficient for modification of Langmuir number due to\n"// & - " ratio of Ekman to unstable Obukhov depth if LT_ENHANCE=2.",& + "Coefficient for modification of Langmuir number due to "// & + "ratio of Ekman to unstable Obukhov depth if LT_ENHANCE=2.",& units="nondim", default=0.95) endif ! This gives a minimum decay scale that is typically much less than Angstrom. CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) call log_param(param_file, mdl, "EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m, & - "The (tiny) minimum friction velocity used within the \n"//& + "The (tiny) minimum friction velocity used within the "//& "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1") CS%id_ML_depth = register_diag_field('ocean_model', 'ePBL_h_ML', diag%axesT1, & @@ -2278,7 +2384,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) Time, 'MSTAR applied for LT effect.', 'nondim') call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, temperature and salinity are used as state \n"//& + "If true, temperature and salinity are used as state "//& "variables.", default=.true.) if (max(CS%id_TKE_wind, CS%id_TKE_MKE, CS%id_TKE_conv, & diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 824bab78b2..34b48257bb 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -79,10 +79,10 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, US, CS, ea, eb, ! At least one of the two following arguments must be present. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & optional, intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. ! This subroutine calculates ea and eb, the rates at which a layer entrains ! from the layers above and below. The entrainment rates are proportional to @@ -271,23 +271,25 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, US, CS, ea, eb, if (present(Kd_Lay)) then do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (dt*Kd_lay(i,j,k)) + dtKd(i,k) = GV%Z_to_H**2 * (dt * (US%s_to_T * Kd_lay(i,j,k))) enddo ; enddo if (present(Kd_int)) then do K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt*Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H**2 * (dt * (US%s_to_T * Kd_int(i,j,K))) enddo ; enddo else do K=2,nz ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (0.5*dt*(Kd_lay(i,j,k-1) + Kd_lay(i,j,k))) + dtKd_int(i,K) = GV%Z_to_H**2 * (0.5 * dt & + * (US%s_to_T * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k)))) enddo ; enddo endif else ! Kd_int must be present, or there already would have been an error. do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (0.5*dt*(Kd_int(i,j,K)+Kd_int(i,j,K+1))) + dtKd(i,k) = GV%Z_to_H**2 * (0.5 * dt & + * (US%T_to_s * (Kd_int(i,j,K)+Kd_int(i,j,K+1)))) enddo ; enddo dO K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt*Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H**2 * (dt * (US%T_to_s * Kd_int(i,j,K))) enddo ; enddo endif @@ -2112,12 +2114,12 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "CORRECT_DENSITY", CS%correct_density, & - "If true, and USE_EOS is true, the layer densities are \n"//& - "restored toward their target values by the diapycnal \n"//& + "If true, and USE_EOS is true, the layer densities are "//& + "restored toward their target values by the diapycnal "//& "mixing, as described in Hallberg (MWR, 2000).", & default=.true.) call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & - "The maximum number of iterations that may be used to \n"//& + "The maximum number of iterations that may be used to "//& "calculate the interior diapycnal entrainment.", default=5) ! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] call get_param(param_file, mdl, "KD", Kd, fail_if_missing=.true.) diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 7ca06c6139..15f1116190 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -341,8 +341,8 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) ! write parameters to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "GEOTHERMAL_SCALE", scale, & - "The constant geothermal heat flux, a rescaling \n"//& - "factor for the heat flux read from GEOTHERMAL_FILE, or \n"//& + "The constant geothermal heat flux, a rescaling "//& + "factor for the heat flux read from GEOTHERMAL_FILE, or "//& "0 to disable the geothermal heating.", & units="W m-2 or various", default=0.0) CS%apply_geothermal = .not.(scale == 0.0) @@ -351,14 +351,14 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) call safe_alloc_ptr(CS%geo_heat, isd, ied, jsd, jed) ; CS%geo_heat(:,:) = 0.0 call get_param(param_file, mdl, "GEOTHERMAL_FILE", geo_file, & - "The file from which the geothermal heating is to be \n"//& + "The file from which the geothermal heating is to be "//& "read, or blank to use a constant heating rate.", default=" ") call get_param(param_file, mdl, "GEOTHERMAL_THICKNESS", CS%geothermal_thick, & "The thickness over which to apply geothermal heating.", & units="m", default=0.1) call get_param(param_file, mdl, "GEOTHERMAL_DRHO_DT_INPLACE", CS%dRcv_dT_inplace, & - "The value of drho_dT above which geothermal heating \n"//& - "simply heats water in place instead of moving it between \n"//& + "The value of drho_dT above which geothermal heating "//& + "simply heats water in place instead of moving it between "//& "isopycnal layers. This must be negative.", & units="kg m-3 K-1", default=-0.01) if (CS%dRcv_dT_inplace >= 0.0) call MOM_error(FATAL, "geothermal_init: "//& @@ -370,7 +370,7 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) filename = trim(inputdir)//trim(geo_file) call log_param(param_file, mdl, "INPUTDIR/GEOTHERMAL_FILE", filename) call get_param(param_file, mdl, "GEOTHERMAL_VARNAME", geotherm_var, & - "The name of the geothermal heating variable in \n"//& + "The name of the geothermal heating variable in "//& "GEOTHERMAL_FILE.", default="geo_heat") call MOM_read_data(filename, trim(geotherm_var), CS%geo_heat, G%Domain) do j=jsd,jed ; do i=isd,ied diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 111e8d44e2..2ffdbcb775 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -7,7 +7,6 @@ module MOM_int_tide_input use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : safe_alloc_ptr, post_data, register_diag_field -use MOM_diag_to_Z, only : diag_to_Z_CS, register_Zint_diag, calc_Zint_diags use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -294,7 +293,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "MIN_ZBOT_ITIDES", min_zbot_itides, & - "Turn off internal tidal dissipation when the total \n"//& + "Turn off internal tidal dissipation when the total "//& "ocean depth is less than this value.", units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "UTIDE", utide, & @@ -308,7 +307,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed)) ; CS%TKE_itidal_coef(:,:) = 0.0 call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & - "A topographic wavenumber used with INT_TIDE_DISSIPATION. \n"//& + "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & units="m-1", default=8.e-4*atan(1.0)) @@ -316,16 +315,16 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "A scaling factor for the roughness amplitude with n"//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & - "The maximum internal tide energy source availble to mix \n"//& + "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & units="W m-2", default=1.0e3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & - "If true, read a file (given by TIDEAMP_FILE) containing \n"//& + "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) if (read_tideamp) then call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & - "The path to the file containing the spatially varying \n"//& + "The path to the file containing the spatially varying "//& "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) @@ -333,7 +332,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & - "The path to the file containing the sub-grid-scale \n"//& + "The path to the file containing the sub-grid-scale "//& "topographic roughness amplitude with INT_TIDE_DISSIPATION.", & fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 428048665b..b5caeb2f53 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -2021,86 +2021,86 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, & "Parameterization of shear-driven turbulence following Jackson, Hallberg and Legg, JPO 2008") call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_init, & - "If true, use the Jackson-Hallberg-Legg (JPO 2008) \n"//& + "If true, use the Jackson-Hallberg-Legg (JPO 2008) "//& "shear mixing parameterization.", default=.false.) call get_param(param_file, mdl, "VERTEX_SHEAR", CS%KS_at_vertex, & - "If true, do the calculations of the shear-driven mixing \n"//& + "If true, do the calculations of the shear-driven mixing "//& "at the cell vertices (i.e., the vorticity points).", & default=.false.) call get_param(param_file, mdl, "RINO_CRIT", CS%RiNo_crit, & "The critical Richardson number for shear mixing.", & units="nondim", default=0.25) call get_param(param_file, mdl, "SHEARMIX_RATE", CS%Shearmix_rate, & - "A nondimensional rate scale for shear-driven entrainment.\n"//& + "A nondimensional rate scale for shear-driven entrainment. "//& "Jackson et al find values in the range of 0.085-0.089.", & units="nondim", default=0.089) call get_param(param_file, mdl, "MAX_RINO_IT", CS%max_RiNo_it, & - "The maximum number of iterations that may be used to \n"//& + "The maximum number of iterations that may be used to "//& "estimate the Richardson number driven mixing.", & units="nondim", default=50) call get_param(param_file, mdl, "KD", KD_normal, default=1.0e-7, do_not_log=.true.) call get_param(param_file, mdl, "KD_KAPPA_SHEAR_0", CS%kappa_0, & - "The background diffusivity that is used to smooth the \n"//& - "density and shear profiles before solving for the \n"//& + "The background diffusivity that is used to smooth the "//& + "density and shear profiles before solving for the "//& "diffusivities. Defaults to value of KD.", & units="m2 s-1", default=KD_normal, scale=US%m_to_Z**2) call get_param(param_file, mdl, "FRI_CURVATURE", CS%FRi_curvature, & - "The nondimensional curvature of the function of the \n"//& - "Richardson number in the kappa source term in the \n"//& + "The nondimensional curvature of the function of the "//& + "Richardson number in the kappa source term in the "//& "Jackson et al. scheme.", units="nondim", default=-0.97) call get_param(param_file, mdl, "TKE_N_DECAY_CONST", CS%C_N, & - "The coefficient for the decay of TKE due to \n"//& - "stratification (i.e. proportional to N*tke). \n"//& + "The coefficient for the decay of TKE due to "//& + "stratification (i.e. proportional to N*tke). "//& "The values found by Jackson et al. are 0.24-0.28.", & units="nondim", default=0.24) ! call get_param(param_file, mdl, "LAYER_KAPPA_STAGGER", CS%layer_stagger, & ! default=.false.) call get_param(param_file, mdl, "TKE_SHEAR_DECAY_CONST", CS%C_S, & - "The coefficient for the decay of TKE due to shear (i.e. \n"//& - "proportional to |S|*tke). The values found by Jackson \n"//& + "The coefficient for the decay of TKE due to shear (i.e. "//& + "proportional to |S|*tke). The values found by Jackson "//& "et al. are 0.14-0.12.", units="nondim", default=0.14) call get_param(param_file, mdl, "KAPPA_BUOY_SCALE_COEF", CS%lambda, & - "The coefficient for the buoyancy length scale in the \n"//& - "kappa equation. The values found by Jackson et al. are \n"//& + "The coefficient for the buoyancy length scale in the "//& + "kappa equation. The values found by Jackson et al. are "//& "in the range of 0.81-0.86.", units="nondim", default=0.82) call get_param(param_file, mdl, "KAPPA_N_OVER_S_SCALE_COEF2", CS%lambda2_N_S, & - "The square of the ratio of the coefficients of the \n"//& - "buoyancy and shear scales in the diffusivity equation, \n"//& - "Set this to 0 (the default) to eliminate the shear scale. \n"//& + "The square of the ratio of the coefficients of the "//& + "buoyancy and shear scales in the diffusivity equation, "//& + "Set this to 0 (the default) to eliminate the shear scale. "//& "This is only used if USE_JACKSON_PARAM is true.", & units="nondim", default=0.0) call get_param(param_file, mdl, "KAPPA_SHEAR_TOL_ERR", CS%kappa_tol_err, & - "The fractional error in kappa that is tolerated. \n"//& - "Iteration stops when changes between subsequent \n"//& - "iterations are smaller than this everywhere in a \n"//& - "column. The peak diffusivities usually converge most \n"//& + "The fractional error in kappa that is tolerated. "//& + "Iteration stops when changes between subsequent "//& + "iterations are smaller than this everywhere in a "//& + "column. The peak diffusivities usually converge most "//& "rapidly, and have much smaller errors than this.", & units="nondim", default=0.1) call get_param(param_file, mdl, "TKE_BACKGROUND", CS%TKE_bg, & - "A background level of TKE used in the first iteration \n"//& + "A background level of TKE used in the first iteration "//& "of the kappa equation. TKE_BACKGROUND could be 0.", & units="m2 s-2", default=0.0) call get_param(param_file, mdl, "KAPPA_SHEAR_ELIM_MASSLESS", CS%eliminate_massless, & - "If true, massless layers are merged with neighboring \n"//& - "massive layers in this calculation. The default is \n"//& - "true and I can think of no good reason why it should \n"//& + "If true, massless layers are merged with neighboring "//& + "massive layers in this calculation. The default is "//& + "true and I can think of no good reason why it should "//& "be false. This is only used if USE_JACKSON_PARAM is true.", & default=.true.) call get_param(param_file, mdl, "MAX_KAPPA_SHEAR_IT", CS%max_KS_it, & - "The maximum number of iterations that may be used to \n"//& + "The maximum number of iterations that may be used to "//& "estimate the time-averaged diffusivity.", units="nondim", & default=13) call get_param(param_file, mdl, "PRANDTL_TURB", CS%Prandtl_turb, & - "The turbulent Prandtl number applied to shear \n"//& + "The turbulent Prandtl number applied to shear "//& "instability.", units="nondim", default=1.0, do_not_log=.true.) call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & - "A negligibly small velocity magnitude below which velocity \n"//& - "components are set to 0. A reasonable value might be \n"//& - "1e-30 m/s, which is less than an Angstrom divided by \n"//& + "A negligibly small velocity magnitude below which velocity "//& + "components are set to 0. A reasonable value might be "//& + "1e-30 m/s, which is less than an Angstrom divided by "//& "the age of the universe.", units="m s-1", default=0.0) call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", CS%debug, & "If true, write debugging data for the kappa-shear code. \n"//& - "Caution: this option is _very_ verbose and should only \n"//& + "Caution: this option is _very_ verbose and should only "//& "be used in single-column mode!", & default=.false., debuggingParam=.true.) @@ -2112,7 +2112,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%nkml = 1 if (GV%nkml>0) then call get_param(param_file, mdl, "KAPPA_SHEAR_MERGE_ML",merge_mixedlayer, & - "If true, combine the mixed layers together before \n"//& + "If true, combine the mixed layers together before "//& "solving the kappa-shear equations.", default=.true.) if (merge_mixedlayer) CS%nkml = GV%nkml endif @@ -2160,7 +2160,7 @@ logical function kappa_shear_at_vertex(param_file) kappa_shear_at_vertex = .false. if (do_Kappa_Shear) & call get_param(param_file, mdl, "VERTEX_SHEAR", kappa_shear_at_vertex, & - "If true, do the calculations of the shear-driven mixing \n"//& + "If true, do the calculations of the shear-driven mixing "//& "at the cell vertices (i.e., the vorticity points).", & default=.false., do_not_log=.true.) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index e89ded7e13..75aa447e15 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -477,15 +477,15 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) ! parameters for CHL_A routines call get_param(param_file, mdl, "VAR_PEN_SW", CS%var_pen_sw, & - "If true, use one of the CHL_A schemes specified by \n"//& - "OPACITY_SCHEME to determine the e-folding depth of \n"//& + "If true, use one of the CHL_A schemes specified by "//& + "OPACITY_SCHEME to determine the e-folding depth of "//& "incoming short wave radiation.", default=.false.) CS%opacity_scheme = NO_SCHEME ; scheme_string = '' if (CS%var_pen_sw) then call get_param(param_file, mdl, "OPACITY_SCHEME", tmpstr, & - "This character string specifies how chlorophyll \n"//& - "concentrations are translated into opacities. Currently \n"//& + "This character string specifies how chlorophyll "//& + "concentrations are translated into opacities. Currently "//& "valid options include:\n"//& " \t\t MANIZZA_05 - Use Manizza et al., GRL, 2005. \n"//& " \t\t MOREL_88 - Use Morel, JGR, 1988.", & @@ -516,8 +516,8 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") call get_param(param_file, mdl, "CHL_FILE", chl_file, & - "CHL_FILE is the file containing chl_a concentrations in \n"//& - "the variable CHL_A. It is used when VAR_PEN_SW and \n"//& + "CHL_FILE is the file containing chl_a concentrations in "//& + "the variable CHL_A. It is used when VAR_PEN_SW and "//& "CHL_FROM_FILE are true.", fail_if_missing=.true.) filename = trim(slasher(inputdir))//trim(chl_file) call log_param(param_file, mdl, "INPUTDIR/CHL_FILE", filename) @@ -527,12 +527,12 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) endif call get_param(param_file, mdl, "BLUE_FRAC_SW", CS%blue_frac, & - "The fraction of the penetrating shortwave radiation \n"//& + "The fraction of the penetrating shortwave radiation "//& "that is in the blue band.", default=0.5, units="nondim") else call get_param(param_file, mdl, "EXP_OPACITY_SCHEME", tmpstr, & - "This character string specifies which exponential \n"//& - "opacity scheme to utilize. Currently \n"//& + "This character string specifies which exponential "//& + "opacity scheme to utilize. Currently "//& "valid options include:\n"//& " \t\t SINGLE_EXP - Single Exponent decay. \n"//& " \t\t DOUBLE_EXP - Double Exponent decay.", & @@ -548,17 +548,17 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) call MOM_mesg('opacity_init: opacity scheme set to "'//trim(tmpstr)//'".', 5) endif call get_param(param_file, mdl, "PEN_SW_SCALE", CS%pen_sw_scale, & - "The vertical absorption e-folding depth of the \n"//& + "The vertical absorption e-folding depth of the "//& "penetrating shortwave radiation.", units="m", default=0.0) !BGR/ Added for opacity_scheme==double_exp read in 2nd exp-decay and fraction if (CS%Opacity_scheme == DOUBLE_EXP ) then call get_param(param_file, mdl, "PEN_SW_SCALE_2ND", CS%pen_sw_scale_2nd, & - "The (2nd) vertical absorption e-folding depth of the \n"//& - "penetrating shortwave radiation \n"//& + "The (2nd) vertical absorption e-folding depth of the "//& + "penetrating shortwave radiation "//& "(use if SW_EXP_MODE==double.)",& units="m", default=0.0) call get_param(param_file, mdl, "SW_1ST_EXP_RATIO", CS%sw_1st_exp_ratio, & - "The fraction of 1st vertical absorption e-folding depth \n"//& + "The fraction of 1st vertical absorption e-folding depth "//& "penetrating shortwave radiation if SW_EXP_MODE==double.",& units="m", default=0.0) elseif (CS%OPACITY_SCHEME == Single_Exp) then @@ -567,7 +567,7 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) CS%sw_1st_exp_ratio = 1.0 endif call get_param(param_file, mdl, "PEN_SW_FRAC", CS%pen_sw_frac, & - "The fraction of the shortwave radiation that penetrates \n"//& + "The fraction of the shortwave radiation that penetrates "//& "below the surface.", units="nondim", default=0.0) endif @@ -606,7 +606,7 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) endif call get_param(param_file, mdl, "OPACITY_LAND_VALUE", CS%opacity_land_value, & - "The value to use for opacity over land. The default is \n"//& + "The value to use for opacity over land. The default is "//& "10 m-1 - a value for muddy water.", units="m-1", default=10.0) if (.not.associated(optics%opacity_band)) & diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 989b2f0154..cca2d9f94e 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -899,23 +899,23 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "REGULARIZE_SURFACE_LAYERS", CS%regularize_surface_layers, & - "If defined, vertically restructure the near-surface \n"//& - "layers when they have too much lateral variations to \n"//& + "If defined, vertically restructure the near-surface "//& + "layers when they have too much lateral variations to "//& "allow for sensible lateral barotropic transports.", & default=.false.) if (CS%regularize_surface_layers) then call get_param(param_file, mdl, "REGULARIZE_SURFACE_DETRAIN", CS%reg_sfc_detrain, & - "If true, allow the buffer layers to detrain into the \n"//& - "interior as a part of the restructuring when \n"//& + "If true, allow the buffer layers to detrain into the "//& + "interior as a part of the restructuring when "//& "REGULARIZE_SURFACE_LAYERS is true.", default=.true.) endif call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & - "The minimum mixed layer depth if the mixed layer depth \n"//& + "The minimum mixed layer depth if the mixed layer depth "//& "is determined dynamically.", units="m", default=0.0, scale=GV%m_to_H) call get_param(param_file, mdl, "REG_SFC_DEFICIT_TOLERANCE", CS%h_def_tol1, & - "The value of the relative thickness deficit at which \n"//& - "to start modifying the layer structure when \n"//& + "The value of the relative thickness deficit at which "//& + "to start modifying the layer structure when "//& "REGULARIZE_SURFACE_LAYERS is true.", units="nondim", & default=0.5) CS%h_def_tol2 = 0.2 + 0.8*CS%h_def_tol1 @@ -927,9 +927,8 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) ! call get_param(param_file, mdl, "DEBUG_CONSERVATION", CS%debug, & ! "If true, monitor conservation and extrema.", default=.false.) - call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", & - CS%allow_clocks_in_omp_loops, & - "If true, clocks can be called from inside loops that can \n"//& + call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", CS%allow_clocks_in_omp_loops, & + "If true, clocks can be called from inside loops that can "//& "be threaded. To run with multiple threads, set to False.", & default=.true.) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 962a9d07c2..82d3eaa547 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -7,7 +7,6 @@ module MOM_set_diffusivity use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_diag_to_Z, only : diag_to_Z_CS, register_Zint_diag, calc_Zint_diags use MOM_debugging, only : hchksum, uvchksum, Bchksum use MOM_EOS, only : calculate_density, calculate_density_derivs use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE @@ -21,7 +20,7 @@ module MOM_set_diffusivity use MOM_tidal_mixing, only : tidal_mixing_CS, calculate_tidal_mixing use MOM_tidal_mixing, only : setup_tidal_diagnostics, post_tidal_diagnostics use MOM_intrinsic_functions, only : invcosh -use MOM_io, only : slasher, vardesc, var_desc, MOM_read_data +use MOM_io, only : slasher, MOM_read_data use MOM_kappa_shear, only : calculate_kappa_shear, kappa_shear_init, Kappa_shear_CS use MOM_kappa_shear, only : calc_kappa_shear_vertex, kappa_shear_at_vertex use MOM_CVMix_shear, only : calculate_CVMix_shear, CVMix_shear_init, CVMix_shear_cs @@ -75,35 +74,35 @@ module MOM_set_diffusivity real :: cdrag !< quadratic drag coefficient [nondim] real :: IMax_decay !< inverse of a maximum decay scale for !! bottom-drag driven turbulence [Z-1 ~> m-1]. - real :: Kv !< The interior vertical viscosity [Z2 s-1 ~> m2 s-1]. - real :: Kd !< interior diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. - real :: Kd_min !< minimum diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. - real :: Kd_max !< maximum increment for diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. + real :: Kv !< The interior vertical viscosity [Z2 T-1 ~> m2 s-1]. + real :: Kd !< interior diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_min !< minimum diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_max !< maximum increment for diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. !! Set to a negative value to have no limit. real :: Kd_add !< uniform diffusivity added everywhere without - !! filtering or scaling [Z2 s-1 ~> m2 s-1]. - real :: Kdml !< mixed layer diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. + !! filtering or scaling [Z2 T-1 ~> m2 s-1]. + real :: Kdml !< mixed layer diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. !! when bulkmixedlayer==.false. real :: Hmix !< mixed layer thickness [meter] when BULKMIXEDLAYER==.false. type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing logical :: limit_dissipation !< If enabled, dissipation is limited to be larger !! than the following: - real :: dissip_min !< Minimum dissipation [Z2 m-2 W m-3 ~> W m-3] - real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [Z2 m-2 W m-3 ~> W m-3] - real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [Z2 m-2 W m-3 s ~> J m-3] - real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [Z2 m-2 W m-3 s2 ~> J s m-3] - real :: dissip_Kd_min !< Minimum Kd [Z2 s-1 ~> m2 s-1], with dissipation Rho0*Kd_min*N^2 + real :: dissip_min !< Minimum dissipation [kg Z2 m-3 T-3 ~> W m-3] + real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [kg Z2 m-3 T-3 ~> W m-3] + real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [kg Z2 m-3 T-2 ~> J m-3] + real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [kg Z2 m-3 T-1 ~> J s m-3] + real :: dissip_Kd_min !< Minimum Kd [Z2 T-1 ~> m2 s-1], with dissipation Rho0*Kd_min*N^2 real :: TKE_itide_max !< maximum internal tide conversion [W m-2] !! available to mix above the BBL - real :: omega !< Earth's rotation frequency [s-1] + real :: omega !< Earth's rotation frequency [T-1 ~> s-1] logical :: ML_radiation !< allow a fraction of TKE available from wind work !! to penetrate below mixed layer base with a vertical !! decay scale determined by the minimum of !! (1) The depth of the mixed layer, or !! (2) An Ekman length scale. - !! Energy availble to drive mixing below the mixed layer is + !! Energy available to drive mixing below the mixed layer is !! given by E = ML_RAD_COEFF*MSTAR*USTAR**3. Optionally, if !! ML_rad_TKE_decay is true, this is further reduced by a factor !! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is @@ -112,7 +111,7 @@ module MOM_set_diffusivity !! where N2 is the squared buoyancy frequency [s-2] and OMEGA2 !! is the rotation rate of the earth squared. real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence - !! radiated from the base of the mixed layer [Z2 s-1 ~> m2 s-1]. + !! radiated from the base of the mixed layer [Z2 T-1 ~> m2 s-1]. real :: ML_rad_efold_coeff !< non-dim coefficient to scale penetration depth real :: ML_rad_coeff !< coefficient, which scales MSTAR*USTAR^3 to !! obtain energy available for mixing below @@ -121,7 +120,7 @@ module MOM_set_diffusivity !! to ML_rad as applied to the other surface !! sources of TKE in the mixed layer code. real :: ustar_min !< A minimum value of ustar to avoid numerical - !! problems [Z s-1 ~> m s-1]. If the value is small enough, + !! problems [Z T-1 ~> m s-1]. If the value is small enough, !! this parameter should not affect the solution. real :: TKE_decay !< ratio of natural Ekman depth to TKE decay scale [nondim] real :: mstar !< ratio of friction velocity cubed to @@ -144,12 +143,11 @@ module MOM_set_diffusivity logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that !! does not rely on a layer-formulation. real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering - real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [Z2 s-1 ~> m2 s-1] - real :: Kv_molecular !< molecular visc for double diff convect [Z2 s-1 ~> m2 s-1] + real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [Z2 T-1 ~> m2 s-1] + real :: Kv_molecular !< molecular visc for double diff convect [Z2 T-1 ~> m2 s-1] character(len=200) :: inputdir !< The directory in which input files are found type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() !< Control structure for a child module - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() !< Control structure for a child module type(Kappa_shear_CS), pointer :: kappaShear_CSp => NULL() !< Control structure for a child module type(CVMix_shear_cs), pointer :: CVMix_shear_csp => NULL() !< Control structure for a child module type(CVMix_ddiff_cs), pointer :: CVMix_ddiff_csp => NULL() !< Control structure for a child module @@ -159,10 +157,8 @@ module MOM_set_diffusivity !>@{ Diagnostic IDs integer :: id_maxTKE = -1, id_TKE_to_Kd = -1, id_Kd_user = -1 - integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_Kd_BBL_z = -1 - integer :: id_Kd_user_z = -1, id_N2 = -1, id_N2_z = -1 + integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_N2 = -1 integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1 - integer :: id_KT_extra_z = -1, id_KS_extra_z = -1 !!@} end type set_diffusivity_CS @@ -170,17 +166,17 @@ module MOM_set_diffusivity !> This structure has memory for used in calculating diagnostics of diffusivity type diffusivity_diags real, pointer, dimension(:,:,:) :: & - N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [s-2] - Kd_user => NULL(), & !< user-added diffusivity at interfaces [Z2 s-1 ~> m2 s-1] - Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [Z2 s-1 ~> m2 s-1] - Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [W m-2] - maxTKE => NULL(), & !< energy required to entrain to h_max [m3 s-3] - KT_extra => NULL(), & !< double diffusion diffusivity for temp [Z2 s-1 ~> m2 s-1]. - KS_extra => NULL() !< double diffusion diffusivity for saln [Z2 s-1 ~> m2 s-1]. + N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] + Kd_user => NULL(), & !< user-added diffusivity at interfaces [Z2 T-1 ~> m2 s-1] + Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [Z2 T-1 ~> m2 s-1] + Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [kg Z3 m-3 T-3 ~> W m-2] + maxTKE => NULL(), & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] + KT_extra => NULL(), & !< double diffusion diffusivity for temp [Z2 T-1 ~> m2 s-1]. + KS_extra => NULL() !< double diffusion diffusivity for saln [Z2 T-1 ~> m2 s-1]. real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE !! dissipated within a layer and Kd in that layer - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] end type diffusivity_diags @@ -225,13 +221,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & real, intent(in) :: dt !< Time increment [s]. type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 s-1 ~> m2 s-1]. + intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(out) :: Kd_int !< Diapycnal diffusivity at each interface [Z2 s-1 ~> m2 s-1]. + optional, intent(out) :: Kd_int !< Diapycnal diffusivity at each interface [Z2 T-1 ~> m2 s-1]. ! local variables real, dimension(SZI_(G)) :: & - N2_bot ! bottom squared buoyancy frequency [s-2] + N2_bot ! bottom squared buoyancy frequency [T-2 ~> s-2] type(diffusivity_diags) :: dd ! structure w/ arrays of pointers to avail diags @@ -243,35 +239,32 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! after full convective adjustment. real, dimension(SZI_(G),SZK_(G)) :: & - N2_lay, & !< squared buoyancy frequency associated with layers [s-2] - maxTKE, & !< energy required to entrain to h_max [m3 s-3] + N2_lay, & !< squared buoyancy frequency associated with layers [T-2 ~> s-2] + maxTKE, & !< energy required to entrain to h_max [m3 T-3] TKE_to_Kd !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between - !< TKE dissipated within a layer and Kd in that layer, in - !< m2 s-1 / m3 s-3 = [s2 m-1]. + !< TKE dissipated within a layer and Kd in that layer + !< [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)+1) :: & - N2_int, & !< squared buoyancy frequency associated at interfaces [s-2] + N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] dRho_int, & !< locally ref potential density difference across interfaces [kg m-3] - KT_extra, & !< double difusion diffusivity of temperature [Z2 s-1 ~> m2 s-1] - KS_extra !< double difusion diffusivity of salinity [Z2 s-1 ~> m2 s-1] + KT_extra, & !< double difusion diffusivity of temperature [Z2 T-1 ~> m2 s-1] + KS_extra !< double difusion diffusivity of salinity [Z2 T-1 ~> m2 s-1] real :: I_Rho0 ! inverse of Boussinesq density [m3 kg-1] - real :: dissip ! local variable for dissipation calculations [Z2 W m-5 ~> W m-3] - real :: Omega2 ! squared absolute rotation rate [s-2] + real :: dissip ! local variable for dissipation calculations [Z2 kg m-3 T-3 ~> W m-3] + real :: Omega2 ! squared absolute rotation rate [T-2 ~> s-2] logical :: use_EOS ! If true, compute density from T/S using equation of state. - type(p3d) :: z_ptrs(6) ! pointers to diagns to be interpolated into depth space integer :: kb(SZI_(G)) ! The index of the lightest layer denser than the ! buffer layer, or -1 without a bulk mixed layer. - integer :: num_z_diags ! number of diagns to be interpolated to depth space - integer :: z_ids(6) ! id numbers of diagns to be interpolated to depth space logical :: showCallTree ! If true, show the call tree. integer :: i, j, k, is, ie, js, je, nz integer :: isd, ied, jsd, jed - real :: kappa_fill ! diffusivity used to fill massless layers - real :: dt_fill ! timestep used to fill massless layers + real :: kappa_fill ! diffusivity used to fill massless layers [Z2 T-1 ~> m2 s-1] + real :: dt_fill ! timestep used to fill massless layers [T ~> s] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -281,10 +274,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (.not.associated(CS)) call MOM_error(FATAL,"set_diffusivity: "//& "Module must be initialized before it is used.") - I_Rho0 = 1.0/GV%Rho0 - kappa_fill = 1.e-3*US%m_to_Z**2 !### Dimensional constant [m2 s-1]. - dt_fill = 7200. !### Dimensionalconstant [s]. - Omega2 = CS%Omega*CS%Omega + I_Rho0 = 1.0 / GV%Rho0 + ! ### Dimensional parameters + kappa_fill = 1.e-3 * US%m2_s_to_Z2_T + dt_fill = 7200. * US%s_to_T + Omega2 = CS%omega * CS%omega use_EOS = associated(tv%eqn_of_state) @@ -297,14 +291,14 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! If nothing else is specified, this will be the value used. Kd_lay(:,:,:) = CS%Kd Kd_int(:,:,:) = CS%Kd - if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = US%s_to_T * CS%Kv ! Set up arrays for diagnostics. - if ((CS%id_N2 > 0) .or. (CS%id_N2_z > 0)) then + if (CS%id_N2 > 0) then allocate(dd%N2_3d(isd:ied,jsd:jed,nz+1)) ; dd%N2_3d(:,:,:) = 0.0 endif - if ((CS%id_Kd_user > 0) .or. (CS%id_Kd_user_z > 0)) then + if (CS%id_Kd_user > 0) then allocate(dd%Kd_user(isd:ied,jsd:jed,nz+1)) ; dd%Kd_user(:,:,:) = 0.0 endif if (CS%id_Kd_work > 0) then @@ -316,13 +310,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%id_TKE_to_Kd > 0) then allocate(dd%TKE_to_Kd(isd:ied,jsd:jed,nz)) ; dd%TKE_to_Kd(:,:,:) = 0.0 endif - if ((CS%id_KT_extra > 0) .or. (CS%id_KT_extra_z > 0)) then + if (CS%id_KT_extra > 0) then allocate(dd%KT_extra(isd:ied,jsd:jed,nz+1)) ; dd%KT_extra(:,:,:) = 0.0 endif - if ((CS%id_KS_extra > 0) .or. (CS%id_KS_extra_z > 0)) then + if (CS%id_KS_extra > 0) then allocate(dd%KS_extra(isd:ied,jsd:jed,nz+1)) ; dd%KS_extra(:,:,:) = 0.0 endif - if ((CS%id_Kd_BBL > 0) .or. (CS%id_Kd_BBL_z > 0)) then + if (CS%id_Kd_BBL > 0) then allocate(dd%Kd_BBL(isd:ied,jsd:jed,nz+1)) ; dd%Kd_BBL(:,:,:) = 0.0 endif @@ -352,7 +346,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then call full_convection(G, GV, h, tv, T_adj, S_adj, fluxes%p_surf, & - GV%Z_to_H**2*kappa_fill*dt_fill, halo=1) + (GV%Z_to_H**2)*kappa_fill*dt_fill, halo=1) call calc_kappa_shear_vertex(u, v, h, T_adj, S_adj, tv, fluxes%p_surf, visc%Kd_shear, & visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) @@ -394,7 +388,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & call sfc_bkgnd_mixing(G, US, CS%bkgnd_mixing_csp) !$OMP parallel do default(shared) private(dRho_int, N2_lay, N2_int, N2_bot, KT_extra, & - !$OMP KS_extra, TKE_to_Kd,maxTKE, dissip, kb) + !$OMP KS_extra, TKE_to_Kd, maxTKE, dissip, kb) do j=js,je ! Set up variables related to the stratification. @@ -412,14 +406,14 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & call double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, KT_extra, KS_extra) do K=2,nz ; do i=is,ie if (KS_extra(i,K) > KT_extra(i,K)) then ! salt fingering - Kd_lay(i,j,k-1) = Kd_lay(i,j,k-1) + 0.5*KT_extra(i,K) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*KT_extra(i,K) - visc%Kd_extra_S(i,j,k) = (KS_extra(i,K) - KT_extra(i,K)) + Kd_lay(i,j,k-1) = Kd_lay(i,j,k-1) + 0.5 * KT_extra(i,K) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * KT_extra(i,K) + visc%Kd_extra_S(i,j,k) = US%s_to_T * (KS_extra(i,K) - KT_extra(i,K)) visc%Kd_extra_T(i,j,k) = 0.0 elseif (KT_extra(i,K) > 0.0) then ! double-diffusive convection - Kd_lay(i,j,k-1) = Kd_lay(i,j,k-1) + 0.5**KS_extra(i,K) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5**KS_extra(i,K) - visc%Kd_extra_T(i,j,k) = (KT_extra(i,K) - KS_extra(i,K)) + Kd_lay(i,j,k-1) = Kd_lay(i,j,k-1) + 0.5 * KS_extra(i,K) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * KS_extra(i,K) + visc%Kd_extra_T(i,j,k) = US%s_to_T * (KT_extra(i,K) - KS_extra(i,K)) visc%Kd_extra_S(i,j,k) = 0.0 else ! There is no double diffusion at this interface. visc%Kd_extra_T(i,j,k) = 0.0 @@ -447,15 +441,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%useKappaShear .or. CS%use_CVMix_shear) then if (present(Kd_int)) then do K=2,nz ; do i=is,ie - Kd_int(i,j,K) = visc%Kd_shear(i,j,K) + 0.5*(Kd_lay(i,j,k-1) + Kd_lay(i,j,k)) + Kd_int(i,j,K) = (US%T_to_s * visc%Kd_shear(i,j,K)) + 0.5 * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k)) enddo ; enddo do i=is,ie - Kd_int(i,j,1) = visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. + Kd_int(i,j,1) = US%T_to_s * visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. Kd_int(i,j,nz+1) = 0.0 enddo endif do k=1,nz ; do i=is,ie - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*(visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%T_to_s * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) enddo ; enddo else if (present(Kd_int)) then @@ -463,12 +457,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & Kd_int(i,j,1) = Kd_lay(i,j,1) ; Kd_int(i,j,nz+1) = 0.0 enddo do K=2,nz ; do i=is,ie - Kd_int(i,j,K) = 0.5*(Kd_lay(i,j,k-1) + Kd_lay(i,j,k)) + Kd_int(i,j,K) = 0.5 * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k)) enddo ; enddo endif endif - call find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, TKE_to_Kd, & + call find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, (US%s_to_T)*dt, G, GV, US, CS, TKE_to_Kd, & maxTKE, kb) if (associated(dd%maxTKE)) then ; do k=1,nz ; do i=is,ie dd%maxTKE(i,j,k) = maxTKE(i,k) @@ -506,30 +500,31 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & do k=2,nz-1 ; do i=is,ie dissip = max( CS%dissip_min, & ! Const. floor on dissip. CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_lay(i,k)), & ! Floor aka Gargett - CS%dissip_N2 * N2_lay(i,k) ) ! Floor of Kd_min*rho0/F_Ri - Kd_lay(i,j,k) = max( Kd_lay(i,j,k) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2))) ) + CS%dissip_N2 * N2_lay(i,k)) ! Floor of Kd_min*rho0/F_Ri + Kd_lay(i,j,k) = max(Kd_lay(i,j,k) , & ! Apply floor to Kd + dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2)))) enddo ; enddo if (present(Kd_int)) then ; do K=2,nz ; do i=is,ie dissip = max( CS%dissip_min, & ! Const. floor on dissip. CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_int(i,K)), & ! Floor aka Gargett - CS%dissip_N2 * N2_int(i,K) ) ! Floor of Kd_min*rho0/F_Ri - Kd_int(i,j,K) = max( Kd_int(i,j,K) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_int(i,K) + Omega2))) ) + CS%dissip_N2 * N2_int(i,K)) ! Floor of Kd_min*rho0/F_Ri + Kd_int(i,j,K) = max(Kd_int(i,j,K) , & ! Apply floor to Kd + dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_int(i,K) + Omega2)))) enddo ; enddo ; endif endif if (associated(dd%Kd_work)) then do k=1,nz ; do i=is,ie - dd%Kd_Work(i,j,k) = GV%Rho0 * US%Z_to_m**3*Kd_lay(i,j,k) * N2_lay(i,k) * & + dd%Kd_Work(i,j,k) = GV%Rho0 * Kd_lay(i,j,k) * N2_lay(i,k) * & GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 enddo ; enddo endif enddo ! j-loop if (CS%debug) then - call hchksum(Kd_lay ,"Kd_lay", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(Kd_lay ,"Kd_lay", G%HI, haloshift=0, & + scale=US%Z2_T_to_m2_s) if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=US%Z_to_m**2) @@ -595,7 +590,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! tidal mixing call post_tidal_diagnostics(G,GV,h,CS%tm_csp) - num_z_diags = 0 if (CS%tm_csp%Int_tide_dissipation .or. CS%tm_csp%Lee_wave_dissipation .or. & CS%tm_csp%Lowmode_itidal_dissipation) then @@ -604,46 +598,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%id_Kd_Work > 0) call post_data(CS%id_Kd_Work, dd%Kd_Work, CS%diag) if (CS%id_maxTKE > 0) call post_data(CS%id_maxTKE, dd%maxTKE, CS%diag) if (CS%id_TKE_to_Kd > 0) call post_data(CS%id_TKE_to_Kd, dd%TKE_to_Kd, CS%diag) - - if (CS%id_N2_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_N2_z - z_ptrs(num_z_diags)%p => dd%N2_3d - endif - - if (CS%id_Kd_user_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Kd_user_z - z_ptrs(num_z_diags)%p => dd%Kd_user - endif - endif if (CS%id_KT_extra > 0) call post_data(CS%id_KT_extra, dd%KT_extra, CS%diag) if (CS%id_KS_extra > 0) call post_data(CS%id_KS_extra, dd%KS_extra, CS%diag) if (CS%id_Kd_BBL > 0) call post_data(CS%id_Kd_BBL, dd%Kd_BBL, CS%diag) - if (CS%id_KT_extra_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_KT_extra_z - z_ptrs(num_z_diags)%p => dd%KT_extra - endif - - if (CS%id_KS_extra_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_KS_extra_z - z_ptrs(num_z_diags)%p => dd%KS_extra - endif - - if (CS%id_Kd_BBL_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Kd_BBL_z - z_ptrs(num_z_diags)%p => dd%Kd_BBL - endif - - if (num_z_diags > 0) & - call calc_Zint_diags(h, z_ptrs, z_ids, num_z_diags, G, GV, CS%diag_to_Z_CSp) - if (associated(dd%N2_3d)) deallocate(dd%N2_3d) if (associated(dd%Kd_work)) deallocate(dd%Kd_work) if (associated(dd%Kd_user)) deallocate(dd%Kd_user) @@ -670,17 +630,17 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: dRho_int !< Change in locally referenced potential density !! across each interface [kg m-3]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the - !! layers [s-2]. + !! layers [T-2 ~> s-2]. integer, intent(in) :: j !< j-index of row to work on - real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(SZI_(G),SZK_(G)), intent(out) :: TKE_to_Kd !< The conversion rate between the TKE - !! TKE dissipated within a layer and the + real, dimension(SZI_(G),SZK_(G)), intent(out) :: TKE_to_Kd !< The conversion rate between the + !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)), intent(out) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [m3 s-3] + !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] integer, dimension(SZI_(G)), intent(out) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer. ! Local variables @@ -709,33 +669,38 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! undergo before entraining all fluid in the layers ! above or below [Z ~> m]. real :: dRho_lay ! density change across a layer [kg m-3] - real :: Omega2 ! rotation rate squared [s-2] - real :: G_Rho0 ! gravitation accel divided by Bouss ref density [m4 s-2 kg-1] + real :: Omega2 ! rotation rate squared [T-2 ~> s-2] + real :: G_Rho0 ! gravitation accel divided by Bouss ref density [m4 T-2 kg-1 -> m4 s-2 kg-1] + real :: G_IRho0 ! ### Alternate calculation of G_Rho0 for reproducibility real :: I_Rho0 ! inverse of Boussinesq reference density [m3 kg-1] - real :: I_dt ! 1/dt [s-1] + real :: I_dt ! 1/dt [T-1] real :: H_neglect ! negligibly small thickness [H ~> m or kg m-2] - real :: hN2pO2 ! h (N^2 + Omega^2), in [m3 s-2 Z-2 ~> m s-2]. + real :: hN2pO2 ! h (N^2 + Omega^2), in [m3 T-2 Z-2 ~> m s-2]. logical :: do_i(SZI_(G)) integer :: i, k, is, ie, nz, i_rem, kmb, kb_min is = G%isc ; ie = G%iec ; nz = G%ke - I_dt = 1.0/dt - Omega2 = CS%Omega**2 - G_Rho0 = (GV%g_Earth*US%m_to_Z**2) / GV%Rho0 + I_dt = 1.0 / dt + Omega2 = CS%omega**2 H_neglect = GV%H_subroundoff - I_Rho0 = 1.0/GV%Rho0 + ! ### G_Rho0 and G_IRho0 are mathematically identical but give different + ! numerical values. We compute both values for now, but they should be + ! consolidated at some point. + G_Rho0 = (GV%g_Earth * US%m_to_Z**2 * US%T_to_s**2) / GV%Rho0 + I_Rho0 = 1.0 / GV%Rho0 + G_IRho0 = (GV%g_Earth * US%m_to_Z**2 * US%T_to_s**2) * I_Rho0 ! Simple but coordinate-independent estimate of Kd/TKE if (CS%simple_TKE_to_Kd) then do k=1,nz ; do i=is,ie - hN2pO2 = US%Z_to_m**3 * ( GV%H_to_Z * h(i,j,k) ) * ( N2_lay(i,k) + Omega2 ) ! Units of m3 Z-2 s-2. + hN2pO2 = (GV%H_to_Z * h(i,j,k)) * (N2_lay(i,k) + Omega2) ! Units of Z T-2. if (hN2pO2>0.) then - TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of Z2 s2 m-3. + TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of T2 Z-1. else; TKE_to_Kd(i,k) = 0.; endif ! The maximum TKE conversion we allow is really a statement ! about the upper diffusivity we allow. Kd_max must be set. - maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of m3 s-3. + maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of Z3 T-3. enddo ; enddo kb(is:ie) = -1 ! kb should not be used by any code in non-layered mode -AJA return @@ -830,7 +795,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & enddo do k=2,kmb ; do i=is,ie maxTKE(i,k) = 0.0 - TKE_to_Kd(i,k) = US%m_to_Z**3 / ((N2_lay(i,k) + Omega2) * & + TKE_to_Kd(i,k) = 1.0 / ((N2_lay(i,k) + Omega2) * & (GV%H_to_Z*(h(i,j,k) + H_neglect))) enddo ; enddo do k=kmb+1,kb_min-1 ; do i=is,ie @@ -851,11 +816,11 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! dRho_int should already be non-negative, so the max is redundant? dh_max = maxEnt(i,k) * (1.0 + dsp1_ds(i,k)) dRho_lay = 0.5 * max(dRho_int(i,K) + dRho_int(i,K+1), 0.0) - maxTKE(i,k) = I_dt*US%Z_to_m * ((GV%g_Earth * I_Rho0) * & + maxTKE(i,k) = I_dt * (G_IRho0 * & (0.5*max(dRho_int(i,K+1) + dsp1_ds(i,k)*dRho_int(i,K), 0.0))) * & - ((GV%H_to_Z*h(i,j,k) + dh_max) * maxEnt(i,k)) - TKE_to_Kd(i,k) = US%m_to_Z**3 / (G_Rho0 * dRho_lay + & - CS%Omega**2 * GV%H_to_Z*(h(i,j,k) + H_neglect)) + ((GV%H_to_Z*h(i,j,k) + dh_max) * maxEnt(i,k)) + TKE_to_Kd(i,k) = 1.0 / (G_Rho0 * dRho_lay + & + CS%omega**2 * GV%H_to_Z*(h(i,j,k) + H_neglect)) endif enddo ; enddo @@ -884,10 +849,10 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & intent(out) :: dRho_int !< Change in locally referenced potential density !! across each interface [kg m-3]. real, dimension(SZI_(G),SZK_(G)+1), & - intent(out) :: N2_int !< The squared buoyancy frequency at the interfaces [s-2]. + intent(out) :: N2_int !< The squared buoyancy frequency at the interfaces [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(G)), & - intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [s-2]. - real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [s-2]. + intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. ! Local variables real, dimension(SZI_(G),SZK_(G)+1) :: & dRho_int_unfilt, & ! unfiltered density differences across interfaces @@ -906,14 +871,14 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real :: Rml_base ! density of the deepest variable density layer real :: dz_int ! thickness associated with an interface [Z ~> m]. real :: G_Rho0 ! gravitation acceleration divided by Bouss reference density - ! times some unit conversion factors [Z m3 s-2 kg-1 ~> m4 s-2 kg-1]. + ! times some unit conversion factors [Z m3 T-2 kg-1 ~> m4 s-2 kg-1]. real :: H_neglect ! negligibly small thickness, in the same units as h. logical :: do_i(SZI_(G)), do_any integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke - G_Rho0 = (GV%g_Earth*US%m_to_Z**2) / GV%Rho0 + G_Rho0 = (GV%g_Earth*US%m_to_Z**2 * US%T_to_s**2) / GV%Rho0 H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -1056,10 +1021,10 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: Kd_T_dd !< Interface double diffusion diapycnal - !! diffusivity for temp [Z2 s-1 ~> m2 s-1]. + !! diffusivity for temp [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal - !! diffusivity for saln [Z2 s-1 ~> m2 s-1]. + !! diffusivity for saln [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G)) :: & dRho_dT, & ! partial derivatives of density wrt temp [kg m-3 degC-1] @@ -1073,20 +1038,15 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real :: Rrho ! vertical density ratio [nondim] real :: diff_dd ! factor for double-diffusion [nondim] - real :: Kd_dd ! The dominant double diffusive diffusivity [Z2 s-1 ~> m2 s-1] + real :: Kd_dd ! The dominant double diffusive diffusivity [Z2 T-1 ~> m2 s-1] real :: prandtl ! flux ratio for diffusive convection regime real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] - real :: dsfmax ! max diffusivity in case of salt fingering [Z2 s-1 ~> m2 s-1] - real :: Kv_molecular ! molecular viscosity [Z2 s-1 ~> m2 s-1] integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke if (associated(tv%eqn_of_state)) then - dsfmax = US%m_to_Z**2 * 1.e-4 ! max salt fingering diffusivity rescaled to [Z2 s-1 ~> m2 s-1] - Kv_molecular = US%m_to_Z**2 * 1.5e-6 ! molecular viscosity rescaled to [Z2 s-1 ~> m2 s-1] - do i=is,ie pres(i) = 0.0 ; Kd_T_dd(i,1) = 0.0 ; Kd_S_dd(i,1) = 0.0 Kd_T_dd(i,nz+1) = 0.0 ; Kd_S_dd(i,nz+1) = 0.0 @@ -1107,16 +1067,16 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case Rrho = min(alpha_dT / beta_dS, Rrho0) diff_dd = 1.0 - ((RRho-1.0)/(RRho0-1.0)) - Kd_dd = dsfmax * diff_dd*diff_dd*diff_dd - Kd_T_dd(i,K) = 0.7*Kd_dd + Kd_dd = CS%Max_salt_diff_salt_fingers * diff_dd*diff_dd*diff_dd + Kd_T_dd(i,K) = 0.7 * Kd_dd Kd_S_dd(i,K) = Kd_dd elseif ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then ! diffusive convection Rrho = alpha_dT / beta_dS - Kd_dd = Kv_molecular * 0.909*exp(4.6*exp(-0.54*(1/Rrho-1))) + Kd_dd = CS%Kv_molecular * 0.909 * exp(4.6 * exp(-0.54 * (1/Rrho - 1))) prandtl = 0.15*Rrho if (Rrho > 0.5) prandtl = (1.85-0.85/Rrho)*Rrho Kd_T_dd(i,K) = Kd_dd - Kd_S_dd(i,K) = prandtl*Kd_dd + Kd_S_dd(i,K) = prandtl * Kd_dd else Kd_T_dd(i,K) = 0.0 ; Kd_S_dd(i,K) = 0.0 endif @@ -1148,19 +1108,19 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)), intent(in) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [m3 s-3] + !! to its maximum-realizable thickness [m3 T-3 ~> m3 s-3] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers, - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, - !! [Z2 s-1 ~> m2 s-1]. - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1]. ! This routine adds diffusion sustained by flow energy extracted by bottom drag. @@ -1174,19 +1134,19 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! the local ustar, times R0_g [kg m-2] Rho_top, & ! density at top of the BBL [kg m-3] TKE, & ! turbulent kinetic energy available to drive - ! bottom-boundary layer mixing in a layer [m3 s-3] + ! bottom-boundary layer mixing in a layer [Z3 T-3 ~> m3 s-3] I2decay ! inverse of twice the TKE decay scale [Z-1 ~> m-1]. - real :: TKE_to_layer ! TKE used to drive mixing in a layer [m3 s-3] - real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [m3 s-3] - real :: TKE_here ! TKE that goes into mixing in this layer [m3 s-3] + real :: TKE_to_layer ! TKE used to drive mixing in a layer [Z3 T-3 ~> m3 s-3] + real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [Z3 T-3 ~> m3 s-3] + real :: TKE_here ! TKE that goes into mixing in this layer [Z3 T-3 ~> m3 s-3] real :: dRl, dRbot ! temporaries holding density differences [kg m-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar_h ! value of ustar at a thickness point [Z s-1 ~> m s-1]. - real :: absf ! average absolute Coriolis parameter around a thickness point [s-1] - real :: R0_g ! Rho0 / G_Earth [kg s2 Z-1 m-4 ~> kg s2 m-5] + real :: ustar_h ! value of ustar at a thickness point [Z T-1 ~> m s-1]. + real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] + real :: R0_g ! Rho0 / G_Earth [kg T2 Z-1 m-4 ~> kg s2 m-5] real :: I_rho0 ! 1 / RHO0 [m3 kg-1] - real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [Z2 s-1 ~> m2 s-1]. + real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [Z2 T-1 ~> m2 s-1]. logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this ! extracted energy also drives diapycnal mixing. @@ -1206,7 +1166,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) Rayleigh_drag = .true. I_Rho0 = 1.0/GV%Rho0 - R0_g = GV%Rho0 / (US%m_to_Z**2*GV%g_Earth) + R0_g = GV%Rho0 / (US%m_to_Z**2 * US%T_to_s**2 * GV%g_Earth) do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo @@ -1216,11 +1176,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! Any turbulence that makes it into the mixed layers is assumed ! to be relatively small and is discarded. do i=is,ie - ustar_h = visc%ustar_BBL(i,j) + ustar_h = US%T_to_s * visc%ustar_BBL(i,j) if (associated(fluxes%ustar_tidal)) & - ustar_h = ustar_h + US%m_to_Z*fluxes%ustar_tidal(i,j) - absf = 0.25 * US%s_to_T * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) + ustar_h = ustar_h + (US%m_to_Z * US%T_to_s * fluxes%ustar_tidal(i,j)) + absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) if ((ustar_h > 0.0) .and. (absf > 0.5*CS%IMax_decay*ustar_h)) then I2decay(i) = absf / ustar_h else @@ -1228,12 +1188,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! If ustar_h = 0, this is land so this value doesn't matter. I2decay(i) = 0.5*CS%IMax_decay endif - TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * & - exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & + TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & - TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * I_Rho0 * & + TKE(i) = TKE(i) + (US%T_to_s**3 * US%m_to_Z**3 * fluxes%TKE_tidal(i,j)) * I_Rho0 * & (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz)))) ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following @@ -1284,13 +1243,14 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & TKE_to_layer = TKE(i) else dRl = Rint(K+1) - Rint(K) ; dRbot = Rint(K+1) - Rho_top(i) - TKE_to_layer = TKE(i) * dRl * (3.0*dRbot*(Rint(K) - Rho_top(i)) +& - dRl**2) / dRbot**3 + TKE_to_layer = TKE(i) * dRl * & + (3.0*dRbot*(Rint(K) - Rho_top(i)) + dRl**2) / dRbot**3 endif else ; TKE_to_layer = 0.0 ; endif ! TKE_Ray has been initialized to 0 above. - if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%Z_to_m * G%IareaT(i,j) * & + if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * G%IareaT(i,j) * & + US%m_to_Z**2 * US%T_to_s**3 * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1303,33 +1263,33 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & TKE(i) = TKE(i) - TKE_to_layer - if (Kd_lay(i,j,k) < (TKE_to_layer+TKE_Ray)*TKE_to_Kd(i,k)) then - delta_Kd = (TKE_to_layer+TKE_Ray)*TKE_to_Kd(i,k) - Kd_lay(i,j,k) + if (Kd_lay(i,j,k) < (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then + delta_Kd = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,j,k) if ((CS%Kd_max >= 0.0) .and. (delta_Kd > CS%Kd_max)) then delta_Kd = CS%Kd_max Kd_lay(i,j,k) = Kd_lay(i,j,k) + delta_Kd else - Kd_lay(i,j,k) = (TKE_to_layer+TKE_Ray)*TKE_to_Kd(i,k) + Kd_lay(i,j,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) endif - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*delta_Kd - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*delta_Kd + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * delta_Kd + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * delta_Kd if (do_diag_Kd_BBL) then - Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5*delta_Kd - Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5*delta_Kd + Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5 * delta_Kd + Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5 * delta_Kd endif endif else - if (Kd_lay(i,j,k) >= maxTKE(i,k)*TKE_to_Kd(i,k)) then + if (Kd_lay(i,j,k) >= maxTKE(i,k) * TKE_to_Kd(i,k)) then TKE_here = 0.0 TKE(i) = TKE(i) + TKE_Ray - elseif (Kd_lay(i,j,k) + (TKE_to_layer+TKE_Ray)*TKE_to_Kd(i,k) > & - maxTKE(i,k)*TKE_to_Kd(i,k)) then - TKE_here = ( (TKE_to_layer+TKE_Ray) + Kd_lay(i,j,k)/TKE_to_Kd(i,k) ) - & - maxTKE(i,k) + elseif (Kd_lay(i,j,k) + (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & + maxTKE(i,k) * TKE_to_Kd(i,k)) then + TKE_here = ((TKE_to_layer + TKE_Ray) + Kd_lay(i,j,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) + ! ### Non-bracketed ternary sum TKE(i) = TKE(i) - TKE_here + TKE_Ray else - TKE_here = TKE_to_layer + TKE_ray - TKE(i) = TKE(i) - TKE_to_Layer + TKE_here = TKE_to_layer + TKE_Ray + TKE(i) = TKE(i) - TKE_to_layer endif if (TKE(i) < 0.0) TKE(i) = 0.0 ! This should be unnecessary? @@ -1337,11 +1297,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & delta_Kd = TKE_here * TKE_to_Kd(i,k) if (CS%Kd_max >= 0.0) delta_Kd = min(delta_Kd, CS%Kd_max) Kd_lay(i,j,k) = Kd_lay(i,j,k) + delta_Kd - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*delta_Kd - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*delta_Kd + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * delta_Kd + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * delta_Kd if (do_diag_Kd_BBL) then - Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5*delta_Kd - Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5*delta_Kd + Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5 * delta_Kd + Kd_BBL(i,j,K+1) = Kd_BBL(i,j,K+1) + 0.5 * delta_Kd endif endif endif @@ -1382,35 +1342,33 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & !! boundary layer properies, and related fields. integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G),SZK_(G)+1), & - intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [s-2] + intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 s-1 ~> m2 s-1] + intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - intent(inout) :: Kd_int !< Interface net diffusivity [Z2 s-1 ~> m2 s-1] - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 s-1 ~> m2 s-1] + intent(inout) :: Kd_int !< Interface net diffusivity [Z2 T-1 ~> m2 s-1] + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1] ! Local variables - real :: TKE_column ! net TKE input into the column [m3 s-3] - real :: TKE_to_layer ! TKE used to drive mixing in a layer [m3 s-3] - real :: TKE_Ray ! TKE from a layer Rayleigh drag used to drive mixing in that layer [m3 s-3] - real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [m3 s-3] - real :: TKE_consumed ! TKE used for mixing in this layer [m3 s-3] - real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [m3 s-3] + real :: TKE_column ! net TKE input into the column [Z3 T-3 ~> m3 s-3] + real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [Z3 T-3 ~> m3 s-3] + real :: TKE_consumed ! TKE used for mixing in this layer [Z3 T-3 ~> m3 s-3] + real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [Z3 T-3 ~> m3 s-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar ! value of ustar at a thickness point [Z s-1 ~> m s-1]. - real :: ustar2 ! square of ustar, for convenience [Z2 s-2 ~> m2 s-2] - real :: absf ! average absolute value of Coriolis parameter around a thickness point [s-1] + real :: ustar ! value of ustar at a thickness point [Z T-1 ~> m s-1]. + real :: ustar2 ! square of ustar, for convenience [Z2 T-2 ~> m2 s-2] + real :: absf ! average absolute value of Coriolis parameter around a thickness point [T-1 ~> s-1] real :: dh, dhm1 ! thickness of layers k and k-1, respecitvely [Z ~> m]. real :: z_bot ! distance to interface k from bottom [Z ~> m]. real :: D_minus_z ! distance to interface k from surface [Z ~> m]. real :: total_thickness ! total thickness of water column [Z ~> m]. real :: Idecay ! inverse of decay scale used for "Joule heating" loss of TKE with height [Z-1 ~> m-1]. - real :: Kd_wall ! Law of the wall diffusivity [Z2 s-1 ~> m2 s-1]. - real :: Kd_lower ! diffusivity for lower interface [Z2 s-1 ~> m2 s-1] - real :: ustar_D ! u* x D [Z2 s-1 ~> m2 s-1]. + real :: Kd_wall ! Law of the wall diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_lower ! diffusivity for lower interface [Z2 T-1 ~> m2 s-1] + real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. real :: I_Rho0 ! 1 / rho0 - real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [s-2] + real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] logical :: Rayleigh_drag ! Set to true if there are Rayleigh drag velocities defined in visc, on ! the assumption that this extracted energy also drives diapycnal mixing. integer :: i, k, km1 @@ -1421,7 +1379,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & do_diag_Kd_BBL = associated(Kd_BBL) N2_min = 0. - if (CS%LOTW_BBL_use_omega) N2_min = (CS%omega**2) + if (CS%LOTW_BBL_use_omega) N2_min = CS%omega**2 ! Determine whether to add Rayleigh drag contribution to TKE Rayleigh_drag = .false. @@ -1429,32 +1387,32 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & I_Rho0 = 1.0/GV%Rho0 cdrag_sqrt = sqrt(CS%cdrag) - TKE_Ray = 0. ! In case Rayleigh_drag is not used. do i=G%isc,G%iec ! Developed in single-column mode ! Column-wise parameters. - absf = 0.25*US%s_to_T*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! + absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! ! u* at the bottom [m s-1]. - ustar = visc%ustar_BBL(i,j) + ustar = US%T_to_s * visc%ustar_BBL(i,j) ustar2 = ustar**2 ! In add_drag_diffusivity(), fluxes%ustar_tidal is added in. This might be double counting ! since ustar_BBL should already include all contributions to u*? -AJA - if (associated(fluxes%ustar_tidal)) ustar = ustar + US%m_to_Z*fluxes%ustar_tidal(i,j) + if (associated(fluxes%ustar_tidal)) ustar = ustar + (US%m_to_Z * US%T_to_s * fluxes%ustar_tidal(i,j)) ! The maximum decay scale should be something of order 200 m. We use the smaller of u*/f and ! (IMax_decay)^-1 as the decay scale. If ustar = 0, this is land so this value doesn't matter. Idecay = CS%IMax_decay - if ((ustar > 0.0) .and. (absf > CS%IMax_decay*ustar)) Idecay = absf / ustar + if ((ustar > 0.0) .and. (absf > CS%IMax_decay * ustar)) Idecay = absf / ustar - ! Energy input at the bottom [m3 s-3]. - ! (Note that visc%TKE_BBL is in m3 s-3, set in set_BBL_TKE().) + ! Energy input at the bottom [Z3 T-3 ~> m3 s-3]. + ! (Note that visc%TKE_BBL is in [Z3 T-3 ~> m3 s-3], set in set_BBL_TKE().) ! I am still unsure about sqrt(cdrag) in this expressions - AJA TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) ! Add in tidal dissipation energy at the bottom [m3 s-3]. ! Note that TKE_tidal is in [W m-2]. - if (associated(fluxes%TKE_tidal)) TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * I_Rho0 + if (associated(fluxes%TKE_tidal)) & + TKE_column = TKE_column + US%m_to_Z**3*US%T_to_s**3 * fluxes%TKE_tidal(i,j) * I_Rho0 TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column @@ -1472,7 +1430,8 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! Add in additional energy input from bottom-drag against slopes (sides) if (Rayleigh_drag) TKE_remaining = TKE_remaining + & - 0.5*CS%BBL_effic * US%Z_to_m * G%IareaT(i,j) * & + US%m_to_Z**2 * US%T_to_s**3 * & + 0.5*CS%BBL_effic * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1490,18 +1449,18 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & if ( ustar_D + absf * ( z_bot * D_minus_z ) == 0.) then Kd_wall = 0. else - Kd_wall = ( ( von_karm * ustar2 ) * ( z_bot * D_minus_z ) ) / & - ( ustar_D + absf * ( z_bot * D_minus_z ) ) + Kd_wall = ((von_karm * ustar2) * (z_bot * D_minus_z)) & + / (ustar_D + absf * (z_bot * D_minus_z)) endif ! TKE associated with Kd_wall [m3 s-2]. ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = US%Z_to_m**3*Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. if (TKE_Kd_wall > 0.) then TKE_consumed = min(TKE_Kd_wall, TKE_remaining) - Kd_wall = (TKE_consumed/TKE_Kd_wall) * Kd_wall ! Scale Kd so that only TKE_consumed is used. + Kd_wall = (TKE_consumed / TKE_Kd_wall) * Kd_wall ! Scale Kd so that only TKE_consumed is used. else ! Either N2=0 or dh = 0. if (TKE_remaining > 0.) then @@ -1517,7 +1476,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! Add this BBL diffusivity to the model net diffusivity. Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_wall - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*(Kd_wall + Kd_lower) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * (Kd_wall + Kd_lower) Kd_lower = Kd_wall ! Store for next level up. if (do_diag_Kd_BBL) Kd_BBL(i,j,K) = Kd_wall enddo ! k @@ -1535,30 +1494,30 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, type(forcing), intent(in) :: fluxes !< Surface fluxes structure type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 s-1 ~> m2 s-1]. + intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. ! This routine adds effects of mixed layer radiation to the layer diffusivities. real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. - real, dimension(SZI_(G)) :: TKE_ml_flux + real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [Z3 T-3 ~> m3 s-3] real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. - real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation [Z2 s-1 ~> m2 s-1]. + real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation [Z2 T-1 ~> m2 s-1]. - real :: f_sq ! The square of the local Coriolis parameter or a related variable [s-2]. + real :: f_sq ! The square of the local Coriolis parameter or a related variable [T-2 ~> s-2]. real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2]. - real :: ustar_sq ! ustar squared [Z2 s-2 ~> m2 s-2] - real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation [Z2 s-1 ~> m2 s-1]. + real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] + real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation [Z2 T-1 ~> m2 s-1]. real :: C1_6 ! 1/6 - real :: Omega2 ! rotation rate squared [s-2]. + real :: Omega2 ! rotation rate squared [T-2 ~> s-2]. real :: z1 ! layer thickness times I_decay [nondim] real :: dzL ! thickness converted to heights [Z ~> m]. real :: I_decay_len2_TKE ! squared inverse decay lengthscale for @@ -1569,7 +1528,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, integer :: i, k, is, ie, nz, kml is = G%isc ; ie = G%iec ; nz = G%ke - Omega2 = CS%Omega**2 + Omega2 = CS%omega**2 C1_6 = 1.0 / 6.0 kml = GV%nkml h_neglect = GV%H_subroundoff*GV%H_to_Z @@ -1581,17 +1540,17 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, do i=is,ie ; if (do_i(i)) then if (CS%ML_omega_frac >= 1.0) then - f_sq = 4.0*Omega2 + f_sq = 4.0 * Omega2 else - f_sq = 0.25*US%s_to_T**2*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + f_sq = 0.25 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & + (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) if (CS%ML_omega_frac > 0.0) & - f_sq = CS%ML_omega_frac*4.0*Omega2 + (1.0-CS%ML_omega_frac)*f_sq + f_sq = CS%ML_omega_frac * 4.0 * Omega2 + (1.0 - CS%ML_omega_frac) * f_sq endif - ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 + ustar_sq = max(US%T_to_s * fluxes%ustar(i,j), CS%ustar_min)**2 - TKE_ml_flux(i) = (CS%mstar*CS%ML_rad_coeff)*(US%Z_to_m**3*ustar_sq*fluxes%ustar(i,j)) + TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * (US%T_to_s * fluxes%ustar(i,j))) I_decay_len2_TKE = CS%TKE_decay**2 * (f_sq / ustar_sq) if (CS%ML_rad_TKE_decay) & @@ -1605,11 +1564,9 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, ! a more accurate Taylor series approximations for very thin layers. z1 = (GV%H_to_Z*h(i,j,kml+1)) * I_decay(i) if (z1 > 1e-5) then - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,kml+1)) * & - (1.0 - exp(-z1)) + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) else - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,kml+1)) * & - (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) endif Kd_mlr_ml(i) = min(Kd_mlr, CS%ML_rad_kd_max) TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) @@ -1623,7 +1580,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_mlr_ml(i) endif ; enddo ; enddo if (kml<=nz-1) then ; do i=is,ie ; if (do_i(i)) then - Kd_int(i,j,Kml+2) = Kd_int(i,j,Kml+2) + 0.5*Kd_mlr_ml(i) + Kd_int(i,j,Kml+2) = Kd_int(i,j,Kml+2) + 0.5 * Kd_mlr_ml(i) endif ; enddo ; endif endif @@ -1632,21 +1589,23 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, do i=is,ie ; if (do_i(i)) then dzL = GV%H_to_Z*h(i,j,k) ; z1 = dzL*I_decay(i) if (z1 > 1e-5) then - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & - US%m_to_Z * ((1.0 - exp(-z1)) / dzL) + !### I think that this might be dimensionally inconsistent, but untested. -RWH + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 ? + US%m_to_Z * ((1.0 - exp(-z1)) / dzL) ! Units of m-1 ? else - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & - US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) + !### I think that this might be dimensionally inconsistent, but untested. -RWH + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 ? + US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 ? endif Kd_mlr = min(Kd_mlr, CS%ML_rad_kd_max) Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_mlr if (present(Kd_int)) then - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*Kd_mlr - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*Kd_mlr + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * Kd_mlr + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * Kd_mlr endif TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) - if (TKE_ml_flux(i) * I_decay(i) < 0.1*CS%Kd_min*US%Z_to_m**3*Omega2) then + if (TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then do_i(i) = .false. else ; do_any = .true. ; endif endif ; enddo @@ -1783,7 +1742,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) G%areaCu(I,j)*(ustar(I)*ustar(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1)) + & G%areaCv(i,J)*(vstar(i,J)*vstar(i,J))) ) ) - visc%TKE_BBL(i,j) = US%Z_to_m * & + visc%TKE_BBL(i,j) = US%T_to_s**3 * US%m_to_Z**2 * & (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + & G%areaCu(I,j) * (ustar(I)*u2_bbl(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1)) + & @@ -1898,7 +1857,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, CS, j, ds_dsp1, rho_0) end subroutine set_density_ratios -subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z_CSp, int_tide_CSp, & +subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_CSp, & tm_CSp, halo_TS) type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -1909,8 +1868,6 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output. type(set_diffusivity_CS), pointer :: CS !< pointer set to point to the module control !! structure. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< pointer to the Z-diagnostics control - !! structure. type(int_tide_CS), pointer :: int_tide_CSp !< pointer to the internal tides control !! structure (BDM) type(tidal_mixing_cs), pointer :: tm_csp !< pointer to tidal mixing control @@ -1920,7 +1877,6 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z ! local variables real :: decay_length - type(vardesc) :: vd logical :: ML_use_omega ! This include declares and sets the variable "version". @@ -1944,67 +1900,66 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z CS%diag => diag if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp if (associated(tm_csp)) CS%tm_csp => tm_csp - if (associated(diag_to_Z_CSp)) CS%diag_to_Z_CSp => diag_to_Z_CSp ! These default values always need to be set. CS%BBL_mixing_as_max = .true. CS%Kdml = 0.0 ; CS%cdrag = 0.003 ; CS%BBL_effic = 0.0 CS%bulkmixedlayer = (GV%nkml > 0) - ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "FLUX_RI_MAX", CS%FluxRi_max, & - "The flux Richardson number where the stratification is \n"//& - "large enough that N2 > omega2. The full expression for \n"//& - "the Flux Richardson number is usually \n"//& + "The flux Richardson number where the stratification is "//& + "large enough that N2 > omega2. The full expression for "//& + "the Flux Richardson number is usually "//& "FLUX_RI_MAX*N2/(N2+OMEGA2).", default=0.2) call get_param(param_file, mdl, "OMEGA", CS%omega, & "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5) + default=7.2921e-5, scale=US%T_to_s) call get_param(param_file, mdl, "ML_RADIATION", CS%ML_radiation, & - "If true, allow a fraction of TKE available from wind \n"//& - "work to penetrate below the base of the mixed layer \n"//& - "with a vertical decay scale determined by the minimum \n"//& - "of: (1) The depth of the mixed layer, (2) an Ekman \n"//& + "If true, allow a fraction of TKE available from wind "//& + "work to penetrate below the base of the mixed layer "//& + "with a vertical decay scale determined by the minimum "//& + "of: (1) The depth of the mixed layer, (2) an Ekman "//& "length scale.", default=.false.) if (CS%ML_radiation) then ! This give a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_subroundoff*GV%H_to_Z) + CS%ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + GV%H_subroundoff*GV%H_to_Z) call get_param(param_file, mdl, "ML_RAD_EFOLD_COEFF", CS%ML_rad_efold_coeff, & - "A coefficient that is used to scale the penetration \n"//& - "depth for turbulence below the base of the mixed layer. \n"//& + "A coefficient that is used to scale the penetration "//& + "depth for turbulence below the base of the mixed layer. "//& "This is only used if ML_RADIATION is true.", units="nondim", & default=0.2) call get_param(param_file, mdl, "ML_RAD_KD_MAX", CS%ML_rad_kd_max, & - "The maximum diapycnal diffusivity due to turbulence \n"//& - "radiated from the base of the mixed layer. \n"//& + "The maximum diapycnal diffusivity due to turbulence "//& + "radiated from the base of the mixed layer. "//& "This is only used if ML_RADIATION is true.", & - units="m2 s-1", default=1.0e-3, scale=US%m_to_Z**2) + units="m2 s-1", default=1.0e-3, & + scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ML_RAD_COEFF", CS%ML_rad_coeff, & - "The coefficient which scales MSTAR*USTAR^3 to obtain \n"//& - "the energy available for mixing below the base of the \n"//& + "The coefficient which scales MSTAR*USTAR^3 to obtain "//& + "the energy available for mixing below the base of the "//& "mixed layer. This is only used if ML_RADIATION is true.", & units="nondim", default=0.2) call get_param(param_file, mdl, "ML_RAD_APPLY_TKE_DECAY", CS%ML_rad_TKE_decay, & - "If true, apply the same exponential decay to ML_rad as \n"//& - "is applied to the other surface sources of TKE in the \n"//& + "If true, apply the same exponential decay to ML_rad as "//& + "is applied to the other surface sources of TKE in the "//& "mixed layer code. This is only used if ML_RADIATION is true.", & default=.true.) call get_param(param_file, mdl, "MSTAR", CS%mstar, & - "The ratio of the friction velocity cubed to the TKE \n"//& + "The ratio of the friction velocity cubed to the TKE "//& "input to the mixed layer.", "units=nondim", default=1.2) call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & "The ratio of the natural Ekman depth to the TKE decay scale.", & units="nondim", default=2.5) call get_param(param_file, mdl, "ML_USE_OMEGA", ML_use_omega, & - "If true, use the absolute rotation rate instead of the \n"//& - "vertical component of rotation when setting the decay \n"//& + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (ML_use_omega) then @@ -2012,59 +1967,60 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%ML_omega_frac, & - "When setting the decay scale for turbulence, use this \n"//& - "fraction of the absolute rotation rate blended with the \n"//& + "When setting the decay scale for turbulence, use this "//& + "fraction of the absolute rotation rate blended with the "//& "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & units="nondim", default=omega_frac_dflt) endif call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & - "If true, the bottom stress is calculated with a drag \n"//& - "law of the form c_drag*|u|*u. The velocity magnitude \n"//& - "may be an assumed value or it may be based on the \n"//& - "actual velocity in the bottommost HBBL, depending on \n"//& + "If true, the bottom stress is calculated with a drag "//& + "law of the form c_drag*|u|*u. The velocity magnitude "//& + "may be an assumed value or it may be based on the "//& + "actual velocity in the bottommost HBBL, depending on "//& "LINEAR_DRAG.", default=.true.) if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & - "The drag coefficient relating the magnitude of the \n"//& - "velocity field to the bottom stress. CDRAG is only used \n"//& + "The drag coefficient relating the magnitude of the "//& + "velocity field to the bottom stress. CDRAG is only used "//& "if BOTTOMDRAGLAW is true.", units="nondim", default=0.003) call get_param(param_file, mdl, "BBL_EFFIC", CS%BBL_effic, & - "The efficiency with which the energy extracted by \n"//& - "bottom drag drives BBL diffusion. This is only \n"//& + "The efficiency with which the energy extracted by "//& + "bottom drag drives BBL diffusion. This is only "//& "used if BOTTOMDRAGLAW is true.", units="nondim", default=0.20) call get_param(param_file, mdl, "BBL_MIXING_MAX_DECAY", decay_length, & - "The maximum decay scale for the BBL diffusion, or 0 \n"//& - "to allow the mixing to penetrate as far as \n"//& - "stratification and rotation permit. The default is 0. \n"//& + "The maximum decay scale for the BBL diffusion, or 0 "//& + "to allow the mixing to penetrate as far as "//& + "stratification and rotation permit. The default is 0. "//& "This is only used if BOTTOMDRAGLAW is true.", & units="m", default=0.0, scale=US%m_to_Z) CS%IMax_decay = 1.0 / (200.0*US%m_to_Z) !### This is inconsistent with the description above. if (decay_length > 0.0) CS%IMax_decay = 1.0/decay_length call get_param(param_file, mdl, "BBL_MIXING_AS_MAX", CS%BBL_mixing_as_max, & - "If true, take the maximum of the diffusivity from the \n"//& - "BBL mixing and the other diffusivities. Otherwise, \n"//& - "diffusiviy from the BBL_mixing is simply added.", & + "If true, take the maximum of the diffusivity from the "//& + "BBL mixing and the other diffusivities. Otherwise, "//& + "diffusivity from the BBL_mixing is simply added.", & default=.true.) call get_param(param_file, mdl, "USE_LOTW_BBL_DIFFUSIVITY", CS%use_LOTW_BBL_diffusivity, & - "If true, uses a simple, imprecise but non-coordinate dependent, model\n"//& - "of BBL mixing diffusivity based on Law of the Wall. Otherwise, uses\n"//& + "If true, uses a simple, imprecise but non-coordinate dependent, model "//& + "of BBL mixing diffusivity based on Law of the Wall. Otherwise, uses "//& "the original BBL scheme.", default=.false.) if (CS%use_LOTW_BBL_diffusivity) then call get_param(param_file, mdl, "LOTW_BBL_USE_OMEGA", CS%LOTW_BBL_use_omega, & - "If true, use the maximum of Omega and N for the TKE to diffusion\n"//& + "If true, use the maximum of Omega and N for the TKE to diffusion "//& "calculation. Otherwise, N is N.", default=.true.) endif else CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL endif CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & - 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=US%Z_to_m**2) + 'Bottom Boundary Layer Diffusivity', 'm2 s-1', & + conversion=US%Z2_T_to_m2_s) call get_param(param_file, mdl, "SIMPLE_TKE_TO_KD", CS%simple_TKE_to_Kd, & - "If true, uses a simple estimate of Kd/TKE that will\n"//& - "work for arbitrary vertical coordinates. If false,\n"//& - "calculates Kd/TKE and bounds based on exact energetics/n"//& + "If true, uses a simple estimate of Kd/TKE that will "//& + "work for arbitrary vertical coordinates. If false, "//& + "calculates Kd/TKE and bounds based on exact energetics "//& "for an isopycnal layer-formulation.", & default=.false.) @@ -2072,27 +2028,31 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp) call get_param(param_file, mdl, "KV", CS%Kv, & - "The background kinematic viscosity in the interior. \n"//& + "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m_to_Z**2, fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, & + fail_if_missing=.true.) call get_param(param_file, mdl, "KD", CS%Kd, & - "The background diapycnal diffusivity of density in the \n"//& - "interior. Zero or the molecular value, ~1e-7 m2 s-1, \n"//& - "may be used.", units="m2 s-1", scale=US%m_to_Z**2, fail_if_missing=.true.) + "The background diapycnal diffusivity of density in the "//& + "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& + "may be used.", units="m2 s-1", scale=US%m2_s_to_Z2_T, & + fail_if_missing=.true.) call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z_to_m**2, scale=US%m_to_Z**2) + units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, & + scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & - "The maximum permitted increment for the diapycnal \n"//& - "diffusivity from TKE-based parameterizations, or a \n"//& - "negative value for no limit.", units="m2 s-1", default=-1.0, scale=US%m_to_Z**2) + "The maximum permitted increment for the diapycnal "//& + "diffusivity from TKE-based parameterizations, or a "//& + "negative value for no limit.", units="m2 s-1", default=-1.0, & + scale=US%m2_s_to_Z2_T) if (CS%simple_TKE_to_Kd .and. CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: To use SIMPLE_TKE_TO_KD, KD_MAX must be set to >0.") call get_param(param_file, mdl, "KD_ADD", CS%Kd_add, & - "A uniform diapycnal diffusivity that is added \n"//& + "A uniform diapycnal diffusivity that is added "//& "everywhere without any filtering or scaling.", & - units="m2 s-1", default=0.0, scale=US%m_to_Z**2) + units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) if (CS%use_LOTW_BBL_diffusivity .and. CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: KD_MAX must be set (positive) when "// & "USE_LOTW_BBL_DIFFUSIVITY=True.") @@ -2106,14 +2066,16 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z CS%Kdml = CS%Kd ! This is not used with a bulk mixed layer, but also ! cannot be a NaN. else + ! ### This parameter is unused and is staged for deletion call get_param(param_file, mdl, "KDML", CS%Kdml, & - "If BULKMIXEDLAYER is false, KDML is the elevated \n"//& - "diapycnal diffusivity in the topmost HMIX of fluid. \n"//& + "If BULKMIXEDLAYER is false, KDML is the elevated "//& + "diapycnal diffusivity in the topmost HMIX of fluid. "//& "KDML is only used if BULKMIXEDLAYER is false.", & - units="m2 s-1", default=CS%Kd*US%Z_to_m**2, scale=US%m_to_Z**2) + units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, & + scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & - "The prescribed depth over which the near-surface \n"//& - "viscosity and diffusivity are elevated when the bulk \n"//& + "The prescribed depth over which the near-surface "//& + "viscosity and diffusivity are elevated when the bulk "//& "mixed layer is not used.", units="m", fail_if_missing=.true.) endif call get_param(param_file, mdl, "DEBUG", CS%debug, & @@ -2125,21 +2087,23 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z default=.false.) call get_param(param_file, mdl, "DISSIPATION_MIN", CS%dissip_min, & - "The minimum dissipation by which to determine a lower \n"//& - "bound of Kd (a floor).", units="W m-3", default=0.0, scale=US%m_to_Z**2) + "The minimum dissipation by which to determine a lower "//& + "bound of Kd (a floor).", units="W m-3", default=0.0, & + scale=US%m2_s_to_Z2_T*(US%T_to_s**2)) call get_param(param_file, mdl, "DISSIPATION_N0", CS%dissip_N0, & - "The intercept when N=0 of the N-dependent expression \n"//& - "used to set a minimum dissipation by which to determine \n"//& + "The intercept when N=0 of the N-dependent expression "//& + "used to set a minimum dissipation by which to determine "//& "a lower bound of Kd (a floor): A in eps_min = A + B*N.", & - units="W m-3", default=0.0, scale=US%m_to_Z**2) + units="W m-3", default=0.0, & + scale=US%m2_s_to_Z2_T*(US%T_to_s**2)) call get_param(param_file, mdl, "DISSIPATION_N1", CS%dissip_N1, & - "The coefficient multiplying N, following Gargett, used to \n"//& - "set a minimum dissipation by which to determine a lower \n"//& + "The coefficient multiplying N, following Gargett, used to "//& + "set a minimum dissipation by which to determine a lower "//& "bound of Kd (a floor): B in eps_min = A + B*N", & - units="J m-3", default=0.0, scale=US%m_to_Z**2) + units="J m-3", default=0.0, scale=US%m2_s_to_Z2_T*US%T_to_s) call get_param(param_file, mdl, "DISSIPATION_KD_MIN", CS%dissip_Kd_min, & "The minimum vertical diffusivity applied as a floor.", & - units="m2 s-1", default=0.0, scale=US%m_to_Z**2) + units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) CS%limit_dissipation = (CS%dissip_min>0.) .or. (CS%dissip_N1>0.) .or. & (CS%dissip_N0>0.) .or. (CS%dissip_Kd_min>0.) @@ -2148,39 +2112,34 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z CS%dissip_N2 = CS%dissip_Kd_min * GV%Rho0 / CS%FluxRi_max CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & - 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=US%Z_to_m**2) + 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', & + conversion=US%Z2_T_to_m2_s) if (CS%tm_csp%Int_tide_dissipation .or. CS%tm_csp%Lee_wave_dissipation .or. & CS%tm_csp%Lowmode_itidal_dissipation) then CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & - 'Work done by Diapycnal Mixing', 'W m-2') + 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%Z_to_m**3*US%s_to_T**3) CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & - 'Maximum layer TKE', 'm3 s-3') + 'Maximum layer TKE', 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & - 'Convert TKE to Kd', 's2 m', conversion=US%Z_to_m**2) + 'Convert TKE to Kd', 's2 m', & + conversion=US%Z2_T_to_m2_s*(US%m_to_Z**3*US%T_to_s**3)) CS%id_N2 = register_diag_field('ocean_model', 'N2', diag%axesTi, Time, & 'Buoyancy frequency squared', 's-2', cmor_field_name='obvfsq', & cmor_long_name='Square of seawater buoyancy frequency', & - cmor_standard_name='square_of_brunt_vaisala_frequency_in_sea_water') + cmor_standard_name='square_of_brunt_vaisala_frequency_in_sea_water', & + conversion=US%s_to_T**2) if (CS%user_change_diff) & CS%id_Kd_user = register_diag_field('ocean_model', 'Kd_user', diag%axesTi, Time, & - 'User-specified Extra Diffusivity', 'm2 s-1', conversion=US%Z_to_m**2) - - if (associated(diag_to_Z_CSp)) then - vd = var_desc("N2", "s-2", & - "Buoyancy frequency, interpolated to z", z_grid='z') - CS%id_N2_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) - if (CS%user_change_diff) & - CS%id_Kd_user_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) - endif + 'User-specified Extra Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) endif call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, & - "If true, increase diffusivitives for temperature or salt \n"//& - "based on double-diffusive paramaterization from MOM4/KPP.", & + "If true, increase diffusivites for temperature or salt "//& + "based on double-diffusive parameterization from MOM4/KPP.", & default=.false.) if (CS%double_diffusion) then @@ -2189,31 +2148,20 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z default=2.55, units="nondim") call get_param(param_file, mdl, "MAX_SALT_DIFF_SALT_FINGERS", CS%Max_salt_diff_salt_fingers, & "Maximum salt diffusivity for salt fingering regime.", & - default=1.e-4, units="m2 s-1") + default=1.e-4, units="m2 s-1", scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & - "Molecular viscosity for calculation of fluxes under \n"//& - "double-diffusive convection.", default=1.5e-6, units="m2 s-1") + "Molecular viscosity for calculation of fluxes under "//& + "double-diffusive convection.", default=1.5e-6, units="m2 s-1", & + scale=US%m2_s_to_Z2_T) ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. CS%id_KT_extra = register_diag_field('ocean_model', 'KT_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=US%Z_to_m**2) + 'Double-diffusive diffusivity for temperature', 'm2 s-1', & + conversion=US%Z2_T_to_m2_s) CS%id_KS_extra = register_diag_field('ocean_model', 'KS_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=US%Z_to_m**2) - - if (associated(diag_to_Z_CSp)) then - vd = var_desc("KT_extra", "m2 s-1", & - "Double-Diffusive Temperature Diffusivity, interpolated to z", & - z_grid='z') - CS%id_KT_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) - vd = var_desc("KS_extra", "m2 s-1", & - "Double-Diffusive Salinity Diffusivity, interpolated to z", & - z_grid='z') - CS%id_KS_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) - vd = var_desc("Kd_BBL", "m2 s-1", & - "Bottom Boundary Layer Diffusivity", z_grid='z') - CS%id_Kd_BBL_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) - endif + 'Double-diffusive diffusivity for salinity', 'm2 s-1', & + conversion=US%Z2_T_to_m2_s) endif ! old double-diffusion if (CS%user_change_diff) then diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 75782be0d0..1265067ef2 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1700,12 +1700,12 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) use_CVMix_shear = CVMix_shear_is_used(param_file) use_CVMix_conv = CVMix_conv_is_used(param_file) call get_param(param_file, mdl, "USE_KPP", useKPP, & - "If true, turns on the [CVMix] KPP scheme of Large et al., 1984,\n"// & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& "to calculate diffusivities and non-local transport in the OBL.", & default=.false., do_not_log=.true.) call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", useEPBL, & - "If true, use an implied energetics planetary boundary \n"//& - "layer scheme to determine the diffusivity and viscosity \n"//& + "If true, use an implied energetics planetary boundary "//& + "layer scheme to determine the diffusivity and viscosity "//& "in the surface boundary layer.", default=.false., do_not_log=.true.) endif @@ -1812,65 +1812,65 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%RiNo_mix = .false. ; use_CVMix_ddiff = .false. differential_diffusion = .false. call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & - "If true, the bottom stress is calculated with a drag \n"//& - "law of the form c_drag*|u|*u. The velocity magnitude \n"//& - "may be an assumed value or it may be based on the \n"//& - "actual velocity in the bottommost HBBL, depending on \n"//& + "If true, the bottom stress is calculated with a drag "//& + "law of the form c_drag*|u|*u. The velocity magnitude "//& + "may be an assumed value or it may be based on the "//& + "actual velocity in the bottommost HBBL, depending on "//& "LINEAR_DRAG.", default=.true.) call get_param(param_file, mdl, "CHANNEL_DRAG", CS%Channel_drag, & - "If true, the bottom drag is exerted directly on each \n"//& - "layer proportional to the fraction of the bottom it \n"//& + "If true, the bottom drag is exerted directly on each "//& + "layer proportional to the fraction of the bottom it "//& "overlies.", default=.false.) call get_param(param_file, mdl, "LINEAR_DRAG", CS%linear_drag, & - "If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag \n"//& + "If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag "//& "law is cdrag*DRAG_BG_VEL*u.", default=.false.) call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & do_not_log=.true.) if (adiabatic) then call log_param(param_file, mdl, "ADIABATIC",adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is \n"//& - "true. This assumes that KD = KDML = 0.0 and that \n"//& - "there is no buoyancy forcing, but makes the model \n"//& + "There are no diapycnal mass fluxes if ADIABATIC is "//& + "true. This assumes that KD = KDML = 0.0 and that "//& + "there is no buoyancy forcing, but makes the model "//& "faster by eliminating subroutine calls.", default=.false.) endif if (.not.adiabatic) then CS%RiNo_mix = kappa_shear_is_used(param_file) call get_param(param_file, mdl, "DOUBLE_DIFFUSION", differential_diffusion, & - "If true, increase diffusivitives for temperature or salt \n"//& - "based on double-diffusive paramaterization from MOM4/KPP.", & + "If true, increase diffusivites for temperature or salt "//& + "based on double-diffusive parameterization from MOM4/KPP.", & default=.false.) use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) endif call get_param(param_file, mdl, "PRANDTL_TURB", visc%Prandtl_turb, & - "The turbulent Prandtl number applied to shear \n"//& + "The turbulent Prandtl number applied to shear "//& "instability.", units="nondim", default=1.0) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "DYNAMIC_VISCOUS_ML", CS%dynamic_viscous_ML, & - "If true, use a bulk Richardson number criterion to \n"//& + "If true, use a bulk Richardson number criterion to "//& "determine the mixed layer thickness for viscosity.", & default=.false.) if (CS%dynamic_viscous_ML) then call get_param(param_file, mdl, "BULK_RI_ML", bulk_Ri_ML_dflt, default=0.0) call get_param(param_file, mdl, "BULK_RI_ML_VISC", CS%bulk_Ri_ML, & - "The efficiency with which mean kinetic energy released \n"//& - "by mechanically forced entrainment of the mixed layer \n"//& - "is converted to turbulent kinetic energy. By default, \n"//& + "The efficiency with which mean kinetic energy released "//& + "by mechanically forced entrainment of the mixed layer "//& + "is converted to turbulent kinetic energy. By default, "//& "BULK_RI_ML_VISC = BULK_RI_ML or 0.", units="nondim", & default=bulk_Ri_ML_dflt) call get_param(param_file, mdl, "TKE_DECAY", TKE_decay_dflt, default=0.0) call get_param(param_file, mdl, "TKE_DECAY_VISC", CS%TKE_decay, & - "TKE_DECAY_VISC relates the vertical rate of decay of \n"//& - "the TKE available for mechanical entrainment to the \n"//& - "natural Ekman depth for use in calculating the dynamic \n"//& - "mixed layer viscosity. By default, \n"//& + "TKE_DECAY_VISC relates the vertical rate of decay of "//& + "the TKE available for mechanical entrainment to the "//& + "natural Ekman depth for use in calculating the dynamic "//& + "mixed layer viscosity. By default, "//& "TKE_DECAY_VISC = TKE_DECAY or 0.", units="nondim", & default=TKE_decay_dflt) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & - "If true, use the absolute rotation rate instead of the \n"//& - "vertical component of rotation when setting the decay \n"//& + "If true, use the absolute rotation rate instead of the "//& + "vertical component of rotation when setting the decay "//& "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then @@ -1878,8 +1878,8 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & - "When setting the decay scale for turbulence, use this \n"//& - "fraction of the absolute rotation rate blended with the \n"//& + "When setting the decay scale for turbulence, use this "//& + "fraction of the absolute rotation rate blended with the "//& "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & units="nondim", default=omega_frac_dflt) call get_param(param_file, mdl, "OMEGA", CS%omega, & @@ -1894,62 +1894,62 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS endif call get_param(param_file, mdl, "HBBL", CS%Hbbl, & - "The thickness of a bottom boundary layer with a \n"//& - "viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or \n"//& - "the thickness over which near-bottom velocities are \n"//& - "averaged for the drag law if BOTTOMDRAGLAW is defined \n"//& + "The thickness of a bottom boundary layer with a "//& + "viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or "//& + "the thickness over which near-bottom velocities are "//& + "averaged for the drag law if BOTTOMDRAGLAW is defined "//& "but LINEAR_DRAG is not.", units="m", fail_if_missing=.true.) ! Rescaled later if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & - "CDRAG is the drag coefficient relating the magnitude of \n"//& - "the velocity field to the bottom stress. CDRAG is only \n"//& + "CDRAG is the drag coefficient relating the magnitude of "//& + "the velocity field to the bottom stress. CDRAG is only "//& "used if BOTTOMDRAGLAW is defined.", units="nondim", & default=0.003) call get_param(param_file, mdl, "DRAG_BG_VEL", CS%drag_bg_vel, & - "DRAG_BG_VEL is either the assumed bottom velocity (with \n"//& - "LINEAR_DRAG) or an unresolved velocity that is \n"//& - "combined with the resolved velocity to estimate the \n"//& - "velocity magnitude. DRAG_BG_VEL is only used when \n"//& + "DRAG_BG_VEL is either the assumed bottom velocity (with "//& + "LINEAR_DRAG) or an unresolved velocity that is "//& + "combined with the resolved velocity to estimate the "//& + "velocity magnitude. DRAG_BG_VEL is only used when "//& "BOTTOMDRAGLAW is defined.", units="m s-1", default=0.0) call get_param(param_file, mdl, "BBL_USE_EOS", CS%BBL_use_EOS, & - "If true, use the equation of state in determining the \n"//& - "properties of the bottom boundary layer. Otherwise use \n"//& + "If true, use the equation of state in determining the "//& + "properties of the bottom boundary layer. Otherwise use "//& "the layer target potential densities.", default=.false.) endif call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & - "The minimum bottom boundary layer thickness that can be \n"//& - "used with BOTTOMDRAGLAW. This might be \n"//& - "Kv / (cdrag * drag_bg_vel) to give Kv as the minimum \n"//& + "The minimum bottom boundary layer thickness that can be "//& + "used with BOTTOMDRAGLAW. This might be "//& + "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& "near-bottom viscosity.", units="m", default=0.0) ! Rescaled later call get_param(param_file, mdl, "HTBL_SHELF_MIN", CS%Htbl_shelf_min, & - "The minimum top boundary layer thickness that can be \n"//& - "used with BOTTOMDRAGLAW. This might be \n"//& - "Kv / (cdrag * drag_bg_vel) to give Kv as the minimum \n"//& + "The minimum top boundary layer thickness that can be "//& + "used with BOTTOMDRAGLAW. This might be "//& + "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& "near-top viscosity.", units="m", default=CS%BBL_thick_min, scale=GV%m_to_H) call get_param(param_file, mdl, "HTBL_SHELF", CS%Htbl_shelf, & - "The thickness over which near-surface velocities are \n"//& - "averaged for the drag law under an ice shelf. By \n"//& + "The thickness over which near-surface velocities are "//& + "averaged for the drag law under an ice shelf. By "//& "default this is the same as HBBL", units="m", default=CS%Hbbl, scale=GV%m_to_H) ! These unit conversions are out outside the get_param calls because the are also defaults. CS%Hbbl = CS%Hbbl * GV%m_to_H ! Rescale CS%BBL_thick_min = CS%BBL_thick_min * GV%m_to_H ! Rescale call get_param(param_file, mdl, "KV", Kv_background, & - "The background kinematic viscosity in the interior. \n"//& + "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true.) call get_param(param_file, mdl, "ADD_KV_SLOW", visc%add_Kv_slow, & - "If true, the background vertical viscosity in the interior \n"//& - "(i.e., tidal + background + shear + convenction) is addded \n"// & - "when computing the coupling coefficient. The purpose of this \n"// & - "flag is to be able to recover previous answers and it will likely \n"// & + "If true, the background vertical viscosity in the interior "//& + "(i.e., tidal + background + shear + convection) is added "//& + "when computing the coupling coefficient. The purpose of this "//& + "flag is to be able to recover previous answers and it will likely "//& "be removed in the future since this option should always be true.", & default=.false.) call get_param(param_file, mdl, "USE_KPP", use_KPP, & - "If true, turns on the [CVMix] KPP scheme of Large et al., 1994,\n"// & - "to calculate diffusivities and non-local transport in the OBL.", & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& + "to calculate diffusivities and non-local transport in the OBL.", & do_not_log=.true., default=.false.) if (use_KPP .and. visc%add_Kv_slow) call MOM_error(FATAL,"set_visc_init: "//& @@ -1971,10 +1971,10 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (smag_const1 >= 0.0) cSmag_chan_dflt = smag_const1 call get_param(param_file, mdl, "SMAG_CONST_CHANNEL", CS%c_Smag, & - "The nondimensional Laplacian Smagorinsky constant used \n"//& - "in calculating the channel drag if it is enabled. The \n"//& - "default is to use the same value as SMAG_LAP_CONST if \n"//& - "it is defined, or 0.15 if it is not. The value used is \n"//& + "The nondimensional Laplacian Smagorinsky constant used "//& + "in calculating the channel drag if it is enabled. The "//& + "default is to use the same value as SMAG_LAP_CONST if "//& + "it is defined, or 0.15 if it is not. The value used is "//& "also 0.15 if the specified value is negative.", & units="nondim", default=cSmag_chan_dflt) if (CS%c_Smag < 0.0) CS%c_Smag = 0.15 diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index eaa2faf765..978e8d1807 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -118,8 +118,8 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & ! Set default, read and log parameters call log_version(param_file, mdl, version) call get_param(param_file, mdl, "SPONGE", use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) if (.not.use_sponge) return @@ -188,7 +188,7 @@ end subroutine initialize_sponge !> This subroutine sets up diagnostics for the sponges. It is separate !! from initialize_sponge because it requires fields that are not readily -!! availble where initialize_sponge is called. +!! available where initialize_sponge is called. subroutine init_sponge_diags(Time, G, diag, CS) type(time_type), target, intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 6f85bc5dbe..024c3125e7 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -5,15 +5,13 @@ module MOM_tidal_mixing use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, post_data -use MOM_diag_to_Z, only : diag_to_Z_CS, register_Zint_diag -use MOM_diag_to_Z, only : calc_Zint_diags use MOM_debugging, only : hchksum use MOM_EOS, only : calculate_density use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc, field_size +use MOM_io, only : slasher, MOM_read_data, field_size use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_string_functions, only : uppercase, lowercase use MOM_unit_scaling, only : unit_scale_type @@ -45,11 +43,11 @@ module MOM_tidal_mixing type, public :: tidal_mixing_diags ; private real, pointer, dimension(:,:,:) :: & Kd_itidal => NULL(),& !< internal tide diffusivity at interfaces [Z2 s-1 ~> m2 s-1]. - Fl_itidal => NULL(),& !< vertical flux of tidal turbulent dissipation [m3 s-3] + Fl_itidal => NULL(),& !< vertical flux of tidal turbulent dissipation [Z3 T-3 ~> m3 s-3] Kd_Niku => NULL(),& !< lee-wave diffusivity at interfaces [Z2 s-1 ~> m2 s-1]. - Kd_Niku_work => NULL(),& !< layer integrated work by lee-wave driven mixing [W m-2] - Kd_Itidal_Work => NULL(),& !< layer integrated work by int tide driven mixing [W m-2] - Kd_Lowmode_Work => NULL(),& !< layer integrated work by low mode driven mixing [W m-2] + Kd_Niku_work => NULL(),& !< layer integrated work by lee-wave driven mixing [kg Z3 m-3 T-3 ~> W m-2] + Kd_Itidal_Work => NULL(),& !< layer integrated work by int tide driven mixing [kg Z3 m-3 T-3 ~> W m-2] + Kd_Lowmode_Work => NULL(),& !< layer integrated work by low mode driven mixing [kg Z3 m-3 T-3 ~> W m-2] N2_int => NULL(),& !< Bouyancy frequency squared at interfaces [s-2] vert_dep_3d => NULL(),& !< The 3-d mixing energy deposition [W m-3] Schmittner_coeff_3d => NULL() !< The coefficient in the Schmittner et al mixing scheme, in UNITS? @@ -58,9 +56,9 @@ module MOM_tidal_mixing real, pointer, dimension(:,:,:) :: Kd_lowmode => NULL() !< internal tide diffusivity at interfaces !! due to propagating low modes [Z2 s-1 ~> m2 s-1]. real, pointer, dimension(:,:,:) :: Fl_lowmode => NULL() !< vertical flux of tidal turbulent - !! dissipation due to propagating low modes [m3 s-3] + !! dissipation due to propagating low modes [Z3 T-3 ~> m3 s-3] real, pointer, dimension(:,:) :: & - TKE_itidal_used => NULL(),& !< internal tide TKE input at ocean bottom [W m-2] + TKE_itidal_used => NULL(),& !< internal tide TKE input at ocean bottom [kg Z3 m-3 T-3 ~> W m-2] N2_bot => NULL(),& !< bottom squared buoyancy frequency [s-2] N2_meanz => NULL(),& !< vertically averaged buoyancy frequency [s-2] Polzin_decay_scale_scaled => NULL(),& !< vertical scale of decay for tidal dissipation @@ -123,10 +121,10 @@ module MOM_tidal_mixing real :: Polzin_min_decay_scale !< minimum decay scale of the tidal dissipation !! profile in Polzin formulation [Z ~> m]. - real :: TKE_itide_max !< maximum internal tide conversion [W m-2] + real :: TKE_itide_max !< maximum internal tide conversion [kg Z3 m-3 T-3 ~> W m-2] !! available to mix above the BBL - real :: utide !< constant tidal amplitude [m s-1] used if + real :: utide !< constant tidal amplitude [Z T-1 ~> m s-1] if READ_TIDEAMP is false. real :: kappa_itides !< topographic wavenumber and non-dimensional scaling [Z-1 ~> m-1]. real :: kappa_h2_factor !< factor for the product of wavenumber * rms sgs height character(len=200) :: inputdir !< The directory in which to find input files @@ -146,9 +144,10 @@ module MOM_tidal_mixing type(remapping_CS) :: remap_CS !< The control structure for remapping ! Data containers - real, pointer, dimension(:,:) :: TKE_Niku => NULL() !< Lee wave driven Turbulent Kinetic Energy input [W m-2] + real, pointer, dimension(:,:) :: TKE_Niku => NULL() !< Lee wave driven Turbulent Kinetic Energy input + !! [kg Z3 m-3 T-3 ~> W m-2] real, pointer, dimension(:,:) :: TKE_itidal => NULL() !< The internal Turbulent Kinetic Energy input divided - !! by the bottom stratfication [J m-2]. + !! by the bottom stratfication [kg Z3 m-3 T-2 ~> J m-2]. real, pointer, dimension(:,:) :: Nb => NULL() !< The near bottom buoyancy frequency [s-1]. real, pointer, dimension(:,:) :: mask_itidal => NULL() !< A mask of where internal tide energy is input real, pointer, dimension(:,:) :: h2 => NULL() !< Squared bottom depth variance [m2]. @@ -162,8 +161,6 @@ module MOM_tidal_mixing ! Diagnostics type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() !< A pointer to the control structure - !! for remapping diagnostics into Z-space type(tidal_mixing_diags), pointer :: dd => NULL() !< A pointer to a structure of diagnostic arrays !>@{ Diagnostic identifiers @@ -172,9 +169,6 @@ module MOM_tidal_mixing integer :: id_Kd_itidal = -1 integer :: id_Kd_Niku = -1 integer :: id_Kd_lowmode = -1 - integer :: id_Kd_itidal_z = -1 - integer :: id_Kd_Niku_z = -1 - integer :: id_Kd_lowmode_z = -1 integer :: id_Kd_Itidal_Work = -1 integer :: id_Kd_Niku_Work = -1 integer :: id_Kd_Lowmode_Work = -1 @@ -209,14 +203,13 @@ module MOM_tidal_mixing contains !> Initializes internal tidal dissipation scheme for diapycnal mixing -logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_CSp, CS) +logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< The current time. type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< pointer to the Z-diagnostics control type(tidal_mixing_cs), pointer :: CS !< This module's control structure. ! Local variables @@ -225,7 +218,6 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ character(len=20) :: CVMix_tidal_scheme_str, tidal_energy_type character(len=200) :: filename, h2_file, Niku_TKE_input_file character(len=200) :: tidal_energy_file, tideamp_file - type(vardesc) :: vd real :: utide, hamp, prandtl_tidal real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data integer :: i, j, is, ie, js, je @@ -248,7 +240,6 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed CS%diag => diag - if (associated(diag_to_Z_CSp)) CS%diag_to_Z_CSp => diag_to_Z_CSp ! Read parameters call log_version(param_file, mdl, version, & @@ -260,8 +251,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".",do_not_log=.true.) CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", CS%int_tide_dissipation, & - "If true, use an internal tidal dissipation scheme to \n"//& - "drive diapycnal mixing, along the lines of St. Laurent \n"//& + "If true, use an internal tidal dissipation scheme to "//& + "drive diapycnal mixing, along the lines of St. Laurent "//& "et al. (2002) and Simmons et al. (2004).", default=CS%use_CVMix_tidal) ! return if tidal mixing is inactive @@ -273,7 +264,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ ! Read in CVMix tidal scheme if CVMix tidal mixing is on if (CS%use_CVMix_tidal) then call get_param(param_file, mdl, "CVMIX_TIDAL_SCHEME", CVMix_tidal_scheme_str, & - "CVMIX_TIDAL_SCHEME selects the CVMix tidal mixing\n"//& + "CVMIX_TIDAL_SCHEME selects the CVMix tidal mixing "//& "scheme with INT_TIDE_DISSIPATION. Valid values are:\n"//& "\t SIMMONS - Use the Simmons et al (2004) tidal \n"//& "\t mixing scheme.\n"//& @@ -294,11 +285,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ ! Read in vertical profile of tidal energy dissipation if ( CS%CVMix_tidal_scheme.eq.SCHMITTNER .or. .not. CS%use_CVMix_tidal) then call get_param(param_file, mdl, "INT_TIDE_PROFILE", int_tide_profile_str, & - "INT_TIDE_PROFILE selects the vertical profile of energy \n"//& + "INT_TIDE_PROFILE selects the vertical profile of energy "//& "dissipation with INT_TIDE_DISSIPATION. Valid values are:\n"//& "\t STLAURENT_02 - Use the St. Laurent et al exponential \n"//& "\t decay profile.\n"//& - "\t POLZIN_09 - Use the Polzin WKB-streched algebraic \n"//& + "\t POLZIN_09 - Use the Polzin WKB-stretched algebraic \n"//& "\t decay profile.", & default=STLAURENT_PROFILE_STRING) int_tide_profile_str = uppercase(int_tide_profile_str) @@ -318,9 +309,9 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ endif call get_param(param_file, mdl, "LEE_WAVE_DISSIPATION", CS%Lee_wave_dissipation, & - "If true, use an lee wave driven dissipation scheme to \n"//& - "drive diapycnal mixing, along the lines of Nikurashin \n"//& - "(2010) and using the St. Laurent et al. (2002) \n"//& + "If true, use an lee wave driven dissipation scheme to "//& + "drive diapycnal mixing, along the lines of Nikurashin "//& + "(2010) and using the St. Laurent et al. (2002) "//& "and Simmons et al. (2004) vertical profile", default=.false.) if (CS%lee_wave_dissipation) then if (CS%use_CVMix_tidal) then @@ -328,11 +319,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ "be used when CVMix tidal mixing scheme is active.") endif call get_param(param_file, mdl, "LEE_WAVE_PROFILE", tmpstr, & - "LEE_WAVE_PROFILE selects the vertical profile of energy \n"//& + "LEE_WAVE_PROFILE selects the vertical profile of energy "//& "dissipation with LEE_WAVE_DISSIPATION. Valid values are:\n"//& "\t STLAURENT_02 - Use the St. Laurent et al exponential \n"//& "\t decay profile.\n"//& - "\t POLZIN_09 - Use the Polzin WKB-streched algebraic \n"//& + "\t POLZIN_09 - Use the Polzin WKB-stretched algebraic \n"//& "\t decay profile.", & default=STLAURENT_PROFILE_STRING) tmpstr = uppercase(tmpstr) @@ -346,10 +337,10 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ endif call get_param(param_file, mdl, "INT_TIDE_LOWMODE_DISSIPATION", CS%Lowmode_itidal_dissipation, & - "If true, consider mixing due to breaking low modes that \n"//& - "have been remotely generated; as with itidal drag on the \n"//& - "barotropic tide, use an internal tidal dissipation scheme to \n"//& - "drive diapycnal mixing, along the lines of St. Laurent \n"//& + "If true, consider mixing due to breaking low modes that "//& + "have been remotely generated; as with itidal drag on the "//& + "barotropic tide, use an internal tidal dissipation scheme to "//& + "drive diapycnal mixing, along the lines of St. Laurent "//& "et al. (2002) and Simmons et al. (2004).", default=.false.) if ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & @@ -359,29 +350,29 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ "be used when CVMix tidal mixing scheme is active.") endif call get_param(param_file, mdl, "NU_POLZIN", CS%Nu_Polzin, & - "When the Polzin decay profile is used, this is a \n"//& - "non-dimensional constant in the expression for the \n"//& + "When the Polzin decay profile is used, this is a "//& + "non-dimensional constant in the expression for the "//& "vertical scale of decay for the tidal energy dissipation.", & units="nondim", default=0.0697) call get_param(param_file, mdl, "NBOTREF_POLZIN", CS%Nbotref_Polzin, & - "When the Polzin decay profile is used, this is the \n"//& - "Rreference value of the buoyancy frequency at the ocean \n"//& - "bottom in the Polzin formulation for the vertical \n"//& + "When the Polzin decay profile is used, this is the "//& + "reference value of the buoyancy frequency at the ocean "//& + "bottom in the Polzin formulation for the vertical "//& "scale of decay for the tidal energy dissipation.", & units="s-1", default=9.61e-4) call get_param(param_file, mdl, "POLZIN_DECAY_SCALE_FACTOR", & CS%Polzin_decay_scale_factor, & - "When the Polzin decay profile is used, this is a \n"//& - "scale factor for the vertical scale of decay of the tidal \n"//& + "When the Polzin decay profile is used, this is a "//& + "scale factor for the vertical scale of decay of the tidal "//& "energy dissipation.", default=1.0, units="nondim") call get_param(param_file, mdl, "POLZIN_SCALE_MAX_FACTOR", & CS%Polzin_decay_scale_max_factor, & - "When the Polzin decay profile is used, this is a factor \n"//& - "to limit the vertical scale of decay of the tidal \n"//& - "energy dissipation to POLZIN_DECAY_SCALE_MAX_FACTOR \n"//& + "When the Polzin decay profile is used, this is a factor "//& + "to limit the vertical scale of decay of the tidal "//& + "energy dissipation to POLZIN_DECAY_SCALE_MAX_FACTOR "//& "times the depth of the ocean.", units="nondim", default=1.0) call get_param(param_file, mdl, "POLZIN_MIN_DECAY_SCALE", CS%Polzin_min_decay_scale, & - "When the Polzin decay profile is used, this is the \n"//& + "When the Polzin decay profile is used, this is the "//& "minimum vertical decay scale for the vertical profile\n"//& "of internal tide dissipation with the Polzin (2009) formulation", & units="m", default=0.0, scale=US%m_to_Z) @@ -389,20 +380,20 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation) then call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE", CS%Int_tide_decay_scale, & - "The decay scale away from the bottom for tidal TKE with \n"//& + "The decay scale away from the bottom for tidal TKE with "//& "the new coding when INT_TIDE_DISSIPATION is used.", & !units="m", default=0.0) units="m", default=500.0, scale=US%m_to_Z) ! TODO: confirm this new default call get_param(param_file, mdl, "MU_ITIDES", CS%Mu_itides, & - "A dimensionless turbulent mixing efficiency used with \n"//& + "A dimensionless turbulent mixing efficiency used with "//& "INT_TIDE_DISSIPATION, often 0.2.", units="nondim", default=0.2) call get_param(param_file, mdl, "GAMMA_ITIDES", CS%Gamma_itides, & - "The fraction of the internal tidal energy that is \n"//& - "dissipated locally with INT_TIDE_DISSIPATION. \n"//& + "The fraction of the internal tidal energy that is "//& + "dissipated locally with INT_TIDE_DISSIPATION. "//& "THIS NAME COULD BE BETTER.", & units="nondim", default=0.3333) call get_param(param_file, mdl, "MIN_ZBOT_ITIDES", CS%min_zbot_itides, & - "Turn off internal tidal dissipation when the total \n"//& + "Turn off internal tidal dissipation when the total "//& "ocean depth is less than this value.", units="m", default=0.0, scale=US%m_to_Z) endif @@ -415,25 +406,25 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ call safe_alloc_ptr(CS%mask_itidal,isd,ied,jsd,jed) ; CS%mask_itidal(:,:) = 1.0 call get_param(param_file, mdl, "KAPPA_ITIDES", CS%kappa_itides, & - "A topographic wavenumber used with INT_TIDE_DISSIPATION. \n"//& + "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & units="m-1", default=8.e-4*atan(1.0), scale=US%Z_to_m) call get_param(param_file, mdl, "UTIDE", CS%utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) + units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) call safe_alloc_ptr(CS%tideamp,is,ie,js,je) ; CS%tideamp(:,:) = CS%utide call get_param(param_file, mdl, "KAPPA_H2_FACTOR", CS%kappa_h2_factor, & - "A scaling factor for the roughness amplitude with n"//& + "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & - "The maximum internal tide energy source availble to mix \n"//& + "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3) + units="W m-2", default=1.0e3, scale=US%m_to_Z**3*US%T_to_s**3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & - "If true, read a file (given by TIDEAMP_FILE) containing \n"//& + "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) if (read_tideamp) then if (CS%use_CVMix_tidal) then @@ -441,15 +432,15 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ "not compatible with CVMix tidal mixing. ") endif call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & - "The path to the file containing the spatially varying \n"//& + "The path to the file containing the spatially varying "//& "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1) + call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & - "The path to the file containing the sub-grid-scale \n"//& + "The path to the file containing the sub-grid-scale "//& "topographic roughness amplitude with INT_TIDE_DISSIPATION.", & fail_if_missing=(.not.CS%use_CVMix_tidal)) filename = trim(CS%inputdir) // trim(h2_file) @@ -466,8 +457,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ CS%h2(i,j) = hamp*hamp utide = CS%tideamp(i,j) - ! Compute the fixed part of internal tidal forcing; units are [J m-2 = kg s-2] here. - CS%TKE_itidal(i,j) = 0.5*US%Z_to_m * CS%kappa_h2_factor*GV%Rho0*& + ! Compute the fixed part of internal tidal forcing; units are [kg Z3 m-3 T-2 ~> J m-2 = kg s-2] here. + CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%Rho0 * & CS%kappa_itides * CS%h2(i,j) * utide*utide enddo ; enddo @@ -476,11 +467,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ if (CS%Lee_wave_dissipation) then call get_param(param_file, mdl, "NIKURASHIN_TKE_INPUT_FILE",Niku_TKE_input_file, & - "The path to the file containing the TKE input from lee \n"//& + "The path to the file containing the TKE input from lee "//& "wave driven mixing. Used with LEE_WAVE_DISSIPATION.", & fail_if_missing=.true.) call get_param(param_file, mdl, "NIKURASHIN_SCALE",Niku_scale, & - "A non-dimensional factor by which to scale the lee-wave \n"//& + "A non-dimensional factor by which to scale the lee-wave "//& "driven TKE input. Used with LEE_WAVE_DISSIPATION.", & units="nondim", default=1.0) @@ -488,15 +479,16 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ call log_param(param_file, mdl, "INPUTDIR/NIKURASHIN_TKE_INPUT_FILE", & filename) call safe_alloc_ptr(CS%TKE_Niku,is,ie,js,je) ; CS%TKE_Niku(:,:) = 0.0 - call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1 ) ! ??? timelevel -aja + call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja + scale=US%m_to_Z**3*US%T_to_s**3) CS%TKE_Niku(:,:) = Niku_scale * CS%TKE_Niku(:,:) call get_param(param_file, mdl, "GAMMA_NIKURASHIN",CS%Gamma_lee, & - "The fraction of the lee wave energy that is dissipated \n"//& + "The fraction of the lee wave energy that is dissipated "//& "locally with LEE_WAVE_DISSIPATION.", units="nondim", & default=0.3333) call get_param(param_file, mdl, "DECAY_SCALE_FACTOR_LEE",CS%Decay_scale_factor_lee, & - "Scaling for the vertical decay scaleof the local \n"//& + "Scaling for the vertical decay scaleof the local "//& "dissipation of lee waves dissipation.", units="nondim", & default=1.0) else @@ -512,17 +504,17 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ "largest acceptable value for tidal diffusivity", & units="m^2/s", default=50e-4) ! the default is 50e-4 in CVMix, 100e-4 in POP. call get_param(param_file, mdl, "TIDAL_DISS_LIM_TC", CS%tidal_diss_lim_tc, & - "Min allowable depth for dissipation for tidal-energy-constituent data. \n"//& + "Min allowable depth for dissipation for tidal-energy-constituent data. "//& "No dissipation contribution is applied above TIDAL_DISS_LIM_TC.", & units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "TIDAL_ENERGY_FILE",tidal_energy_file, & - "The path to the file containing tidal energy \n"//& + "The path to the file containing tidal energy "//& "dissipation. Used with CVMix tidal mixing schemes.", & fail_if_missing=.true.) call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, & do_not_log=.True.) call get_param(param_file, mdl, "PRANDTL_TIDAL", prandtl_tidal, & - "Prandtl number used by CVMix tidal mixing schemes \n"//& + "Prandtl number used by CVMix tidal mixing schemes "//& "to convert vertical diffusivities into viscosities.", & units="nondim", default=1.0, & do_not_log=.true.) @@ -582,21 +574,25 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ else CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal',diag%axesT1,Time, & - 'Internal Tide Driven Turbulent Kinetic Energy', 'W m-2') + 'Internal Tide Driven Turbulent Kinetic Energy', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Nb = register_diag_field('ocean_model','Nb',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1') CS%id_Kd_lowmode = register_diag_field('ocean_model','Kd_lowmode',diag%axesTi,Time, & - 'Internal Tide Driven Diffusivity (from propagating low modes)', 'm2 s-1', conversion=US%Z_to_m**2) + 'Internal Tide Driven Diffusivity (from propagating low modes)', & + 'm2 s-1', conversion=US%Z_to_m**2) CS%id_Fl_itidal = register_diag_field('ocean_model','Fl_itides',diag%axesTi,Time, & - 'Vertical flux of tidal turbulent dissipation', 'm3 s-3') + 'Vertical flux of tidal turbulent dissipation', & + 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Fl_lowmode = register_diag_field('ocean_model','Fl_lowmode',diag%axesTi,Time, & - 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', 'm3 s-3') + 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', & + 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale',diag%axesT1,Time, & - 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', 'm', conversion=US%Z_to_m) + 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', & + 'm', conversion=US%Z_to_m) CS%id_Polzin_decay_scale_scaled = register_diag_field('ocean_model', & 'Polzin_decay_scale_scaled', diag%axesT1, Time, & @@ -610,39 +606,22 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_ 'Buoyancy frequency squared averaged over the water column', 's-2') CS%id_Kd_Itidal_Work = register_diag_field('ocean_model','Kd_Itidal_Work',diag%axesTL,Time, & - 'Work done by Internal Tide Diapycnal Mixing', 'W m-2') + 'Work done by Internal Tide Diapycnal Mixing', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Kd_Niku_Work = register_diag_field('ocean_model','Kd_Nikurashin_Work',diag%axesTL,Time, & - 'Work done by Nikurashin Lee Wave Drag Scheme', 'W m-2') + 'Work done by Nikurashin Lee Wave Drag Scheme', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Kd_Lowmode_Work = register_diag_field('ocean_model','Kd_Lowmode_Work',diag%axesTL,Time, & - 'Work done by Internal Tide Diapycnal Mixing (low modes)', 'W m-2') + 'Work done by Internal Tide Diapycnal Mixing (low modes)', & + 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) if (CS%Lee_wave_dissipation) then CS%id_TKE_leewave = register_diag_field('ocean_model','TKE_leewave',diag%axesT1,Time, & - 'Lee wave Driven Turbulent Kinetic Energy', 'W m-2') + 'Lee wave Driven Turbulent Kinetic Energy', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_Kd_Niku = register_diag_field('ocean_model','Kd_Nikurashin',diag%axesTi,Time, & 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=US%Z_to_m**2) endif endif ! S%use_CVMix_tidal - - if (associated(CS%diag_to_Z_CSp)) then - vd = var_desc("Kd_itides","m2 s-1", & - "Internal Tide Driven Diffusivity, interpolated to z", z_grid='z') - CS%id_Kd_itidal_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) - if (CS%Lee_wave_dissipation) then - vd = var_desc("Kd_Nikurashin", "m2 s-1", & - "Lee Wave Driven Diffusivity, interpolated to z", z_grid='z') - CS%id_Kd_Niku_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) - endif - if (CS%Lowmode_itidal_dissipation) then - vd = var_desc("Kd_lowmode","m2 s-1", & - "Internal Tide Driven Diffusivity (from low modes), interpolated to z",& - z_grid='z') - CS%id_Kd_lowmode_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) - endif - endif - endif end function tidal_mixing_init @@ -659,28 +638,28 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy - !! frequency [s-2]. + !! frequency [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the - !! layers [s-2]. + !! layers [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int !< The squared buoyancy frequency at the - !! interfaces [s-2]. + !! interfaces [T-2 ~> s-2]. integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE - !! TKE dissipated within a layer and the - !! diapycnal diffusivity witin that layer, + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [m3 s-3] + !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), pointer :: CS !< The control structure for this module real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 s-1 ~> m2 s-1]. + intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. !! Set this to a negative value to have no limit. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 s-1 ~> m2 s-1]. @@ -689,8 +668,8 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C if (CS%use_CVMix_tidal) then call calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) else - call add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, CS, & - N2_lay, Kd_lay, Kd_int, Kd_max) + call add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, & + G, GV, US, CS, N2_lay, Kd_lay, Kd_int, US%s_to_T*Kd_max) endif endif end subroutine calculate_tidal_mixing @@ -705,11 +684,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tidal_mixing_cs), pointer :: CS !< This module's control structure. real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int !< The squared buoyancy - !! frequency at the interfaces [s-2]. + !! frequency at the interfaces [T-2 ~> s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay!< The diapycnal diffusivities in the layers [Z2 s-1 ~> m2 s-1]. + intent(inout) :: Kd_lay!< The diapycnal diffusivities in the layers [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 s-1 ~> m2 s-1]. ! Local variables @@ -721,6 +700,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) real, dimension(SZK_(G)) :: cellHeight ! Height of cell centers [m] real, dimension(SZK_(G)) :: tidal_qe_md ! Tidal dissipation energy interpolated from 3d input ! to model coordinates + real, dimension(SZK_(G)+1) :: N2_int_i ! De-scaled interface buoyancy frequency [s-2] real, dimension(SZK_(G)) :: Schmittner_coeff real, dimension(SZK_(G)) :: h_m ! Cell thickness [m] real, allocatable, dimension(:,:) :: exp_hab_zetar @@ -768,9 +748,14 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) Simmons_coeff = Simmons_coeff / CS%Gamma_itides + ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable + do k = 1,G%ke+1 + N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) + enddo + call CVMix_coeffs_tidal( Mdiff_out = Kv_tidal, & Tdiff_out = Kd_tidal, & - Nsqr = N2_int(i,:), & + Nsqr = N2_int_i, & OceanDepth = -iFaceHeight(G%ke+1),& SimmonsCoeff = Simmons_coeff, & vert_dep = vert_dep, & @@ -781,7 +766,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) ! Update diffusivity do k=1,G%ke - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*US%m_to_Z**2*(Kd_tidal(k) + Kd_tidal(k+1)) ! Rescale from m2 s-1 to Z2 s-1. + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo ! Update viscosity with the proper unit conversion. @@ -864,10 +849,14 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) exp_hab_zetar = exp_hab_zetar, & CVmix_tidal_params_user = CS%CVMix_tidal_params) + ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable + do k = 1,G%ke+1 + N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) + enddo call CVMix_coeffs_tidal_schmittner( Mdiff_out = Kv_tidal, & Tdiff_out = Kd_tidal, & - Nsqr = N2_int(i,:), & + Nsqr = N2_int_i, & OceanDepth = -iFaceHeight(G%ke+1), & vert_dep = vert_dep, & nlev = G%ke, & @@ -879,7 +868,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) ! Update diffusivity do k=1,G%ke - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*US%m_to_Z**2*(Kd_tidal(k) + Kd_tidal(k+1)) ! Rescale from m2 s-1 to Z2 s-1. + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo ! Update viscosity @@ -931,23 +920,23 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy frequency - !! frequency [s-2]. + !! frequency [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the - !! layers [s-2]. + !! layers [T-2 ~> s-2]. integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE - !! TKE dissipated within a layer and the - !! diapycnal diffusivity witin that layer, + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> s2 m-1] + !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [m3 s-3] + !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), pointer :: CS !< The control structure for this module real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 s-1 ~> m2 s-1]. + intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces - !! [Z2 s-1 ~> m2 s-1]. + !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes !! [Z2 s-1 ~> m2 s-1]. @@ -959,9 +948,9 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, htot, & ! total thickness above or below a layer, or the ! integrated thickness in the BBL [Z ~> m]. htot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m]. - TKE_itidal_bot, & ! internal tide TKE at ocean bottom [m3 s-3] - TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [m3 s-3] - TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [m3 s-3] (BDM) + TKE_itidal_bot, & ! internal tide TKE at ocean bottom [Z3 T-3 ~> m3 s-3] + TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [Z3 T-3 ~> m3 s-3] + TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [Z3 T-3 ~> m3 s-3] (BDM) Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] (BDM) @@ -971,9 +960,9 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, ! z*=int(N2/N2_bot) * N2_bot/N2_meanz = int(N2/N2_meanz) ! z0_Polzin_scaled = z0_Polzin * N2_bot/N2_meanz N2_meanz, & ! vertically averaged squared buoyancy frequency [s-2] for WKB scaling - TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) - TKE_Niku_rem, & ! remaining lee-wave TKE - TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) (BDM) + TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) [Z3 T-3 ~> m3 s-3] + TKE_Niku_rem, & ! remaining lee-wave TKE [Z3 T-3 ~> m3 s-3] + TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) [Z3 T-3 ~> m3 s-3] (BDM) TKE_frac_top, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lowmode, & @@ -983,14 +972,14 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, real :: I_rho0 ! 1 / RHO0 [m3 kg-1] real :: Kd_add ! diffusivity to add in a layer [Z2 s-1 ~> m2 s-1]. - real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [m3 s-3] - real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [m3 s-3] - real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [m3 s-3] (BDM) + real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [Z3 T-3 ~> m3 s-3] + real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [Z3 T-3 ~> m3 s-3] + real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [Z3 T-3 ~> m3 s-3] (BDM) real :: frac_used ! fraction of TKE that can be used in a layer [nondim] real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1]. real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1]. real :: z0_psl ! temporary variable [Z ~> m]. - real :: TKE_lowmode_tot ! TKE from all low modes [W m-2] (BDM) + real :: TKE_lowmode_tot ! TKE from all low modes [kg Z3 m-3 T-3 ~> W m-2] (BDM) logical :: use_Polzin, use_Simmons character(len=160) :: mesg ! The text of an error message @@ -1024,8 +1013,8 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, & GV%H_subroundoff*GV%H_to_Z) do i=is,ie - CS%Nb(i,j) = sqrt(N2_bot(i)) - if (associated(dd%N2_bot)) dd%N2_bot(i,j) = N2_bot(i) + CS%Nb(i,j) = sqrt(US%s_to_T**2 * N2_bot(i)) + if (associated(dd%N2_bot)) dd%N2_bot(i,j) = US%s_to_T**2 * N2_bot(i) if ( CS%Int_tide_dissipation ) then if (Izeta*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. Inv_int(i) = 1.0 / (1.0 - exp(-Izeta*htot(i))) @@ -1050,7 +1039,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, ! WKB scaling of the vertical coordinate do i=is,ie ; N2_meanz(i)=0.0 ; enddo do k=1,nz ; do i=is,ie - N2_meanz(i) = N2_meanz(i) + N2_lay(i,k)*GV%H_to_Z*h(i,j,k) + N2_meanz(i) = N2_meanz(i) + (US%s_to_T**2 * N2_lay(i,k)) * GV%H_to_Z * h(i,j,k) enddo ; enddo do i=is,ie N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%H_subroundoff*GV%H_to_Z) @@ -1061,18 +1050,18 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, do i=is,ie ; htot_WKB(i) = htot(i) ; enddo ! do i=is,ie ; htot_WKB(i) = 0.0 ; enddo ! do k=1,nz ; do i=is,ie -! htot_WKB(i) = htot_WKB(i) + GV%H_to_Z*h(i,j,k)*N2_lay(i,k) / N2_meanz(i) +! htot_WKB(i) = htot_WKB(i) + GV%H_to_Z*h(i,j,k) * (US%s_to_T**2 * N2_lay(i,k)) / N2_meanz(i) ! enddo ; enddo ! htot_WKB(i) = htot(i) ! Nearly equivalent and simpler do i=is,ie - CS%Nb(i,j) = sqrt(N2_bot(i)) + CS%Nb(i,j) = sqrt(US%s_to_T**2 * N2_bot(i)) !### In the code below 1.0e-14 is a dimensional constant in [s-3] if ((CS%tideamp(i,j) > 0.0) .and. & (CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 > 1.0e-14) ) then - z0_polzin(i) = US%m_to_Z * CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & + z0_polzin(i) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & CS%Nbotref_Polzin**2 * CS%tideamp(i,j) / & - ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 ) + ( CS%kappa_itides**2 * CS%h2(i,j) * US%T_to_s * CS%Nb(i,j)**3 ) if (z0_polzin(i) < CS%Polzin_min_decay_scale) & z0_polzin(i) = CS%Polzin_min_decay_scale if (N2_meanz(i) > 1.0e-14 ) then !### Here 1.0e-14 has dimensions of s-2. @@ -1118,7 +1107,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, z_from_bot(i) = GV%H_to_Z*h(i,j,nz) ! Use the new formulation for WKB scaling. N2 is referenced to its vertical mean. if (N2_meanz(i) > 1.0e-14 ) then !### Avoid using this dimensional constant. - z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz)*N2_lay(i,nz) / N2_meanz(i) + z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz) * (US%s_to_T**2 * N2_lay(i,nz)) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif enddo endif ! Polzin @@ -1127,7 +1116,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, ! Both Polzin and Simmons: do i=is,ie ! Dissipation of locally trapped internal tide (non-propagating high modes) - TKE_itidal_bot(i) = min(CS%TKE_itidal(i,j)*CS%Nb(i,j),CS%TKE_itide_max) + TKE_itidal_bot(i) = min(CS%TKE_itidal(i,j)*US%T_to_s*CS%Nb(i,j), CS%TKE_itide_max) if (associated(dd%TKE_itidal_used)) & dd%TKE_itidal_used(i,j) = TKE_itidal_bot(i) TKE_itidal_bot(i) = (I_rho0 * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) @@ -1176,8 +1165,8 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)* TKE_frac_top_lowmode(i) ! Actual power expended may be less than predicted if stratification is weak; adjust - if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then - frac_used = max_TKE(i,k) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > (max_TKE(i,k))) then + frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay TKE_lowmode_lay = frac_used * TKE_lowmode_lay @@ -1189,21 +1178,21 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = US%s_to_T * TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add + Kd_lay(i,j,k) = Kd_lay(i,j,k) + (US%T_to_s * Kd_add) if (present(Kd_int)) then - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*Kd_add - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*Kd_add + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * (US%T_to_s * Kd_add) + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * (US%T_to_s * Kd_add) endif ! diagnostics if (associated(dd%Kd_itidal)) then ! If at layers, dd%Kd_itidal is just TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + Kd_add = US%s_to_T * TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_itidal(i,j,K) = dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_Niku(i,j,K) = dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_lowmode(i,j,K) = dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k 1.0e-14 ) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) + GV%H_to_Z*h(i,j,k)*N2_lay(i,k)/N2_meanz(i) + z_from_bot_WKB(i) = z_from_bot_WKB(i) & + + GV%H_to_Z * h(i,j,k) * (US%s_to_T**2 * N2_lay(i,k)) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif ! Fraction of bottom flux predicted to reach top of this layer @@ -1263,8 +1253,8 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)*TKE_frac_top_lowmode(i) ! Actual power expended may be less than predicted if stratification is weak; adjust - if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then - frac_used = max_TKE(i,k) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > (max_TKE(i,k))) then + frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay TKE_lowmode_lay = frac_used * TKE_lowmode_lay @@ -1276,21 +1266,21 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = US%s_to_T * TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add + Kd_lay(i,j,k) = Kd_lay(i,j,k) + (US%T_to_s * Kd_add) if (present(Kd_int)) then - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*Kd_add - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5*Kd_add + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * (US%T_to_s * Kd_add) + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * (US%T_to_s * Kd_add) endif ! diagnostics if (associated(dd%Kd_itidal)) then ! If at layers, this is just dd%Kd_itidal(i,j,K) = TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + Kd_add = US%s_to_T * TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_itidal(i,j,K) = dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_Niku(i,j,K) = dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) dd%Kd_lowmode(i,j,K) = dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k CS%dd - if ((CS%id_Kd_itidal > 0) .or. (CS%id_Kd_itidal_z > 0) .or. & - (CS%id_Kd_Itidal_work > 0)) then + if ((CS%id_Kd_itidal > 0) .or. (CS%id_Kd_Itidal_work > 0)) then allocate(dd%Kd_itidal(isd:ied,jsd:jed,nz+1)) ; dd%Kd_itidal(:,:,:) = 0.0 endif - if ((CS%id_Kd_lowmode > 0) .or. (CS%id_Kd_lowmode_z > 0) .or. & - (CS%id_Kd_lowmode_work > 0)) then + if ((CS%id_Kd_lowmode > 0) .or. (CS%id_Kd_lowmode_work > 0)) then allocate(dd%Kd_lowmode(isd:ied,jsd:jed,nz+1)) ; dd%Kd_lowmode(:,:,:) = 0.0 endif if ( (CS%id_Fl_itidal > 0) ) then @@ -1367,8 +1355,7 @@ subroutine setup_tidal_diagnostics(G,CS) allocate(dd%Polzin_decay_scale_scaled(isd:ied,jsd:jed)) dd%Polzin_decay_scale_scaled(:,:) = 0.0 endif - if ((CS%id_Kd_Niku > 0) .or. (CS%id_Kd_Niku_z > 0) .or. & - (CS%id_Kd_Niku_work > 0)) then + if ((CS%id_Kd_Niku > 0) .or. (CS%id_Kd_Niku_work > 0)) then allocate(dd%Kd_Niku(isd:ied,jsd:jed,nz+1)) ; dd%Kd_Niku(:,:,:) = 0.0 endif if (CS%id_Kd_Niku_work > 0) then @@ -1424,12 +1411,8 @@ subroutine post_tidal_diagnostics(G, GV, h ,CS) type(tidal_mixing_cs), pointer :: CS !< The control structure for this module ! local - integer :: num_z_diags - integer :: z_ids(6) ! id numbers of diagns to be interpolated to depth space - type(p3d) :: z_ptrs(6) ! pointers to diagns to be interpolated into depth space type(tidal_mixing_diags), pointer :: dd => NULL() - num_z_diags = 0 dd => CS%dd if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then @@ -1461,30 +1444,8 @@ subroutine post_tidal_diagnostics(G, GV, h ,CS) call post_data(CS%id_Polzin_decay_scale, dd%Polzin_decay_scale, CS%diag) if (CS%id_Polzin_decay_scale_scaled > 0 ) & call post_data(CS%id_Polzin_decay_scale_scaled, dd%Polzin_decay_scale_scaled, CS%diag) - - if (CS%id_Kd_itidal_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Kd_itidal_z - z_ptrs(num_z_diags)%p => dd%Kd_itidal - endif - - if (CS%id_Kd_Niku_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Kd_Niku_z - z_ptrs(num_z_diags)%p => dd%Kd_Niku - endif - - if (CS%id_Kd_lowmode_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Kd_lowmode_z - z_ptrs(num_z_diags)%p => dd%Kd_lowmode - endif - endif - if (num_z_diags > 0) & - call calc_Zint_diags(h, z_ptrs, z_ids, num_z_diags, G, GV, CS%diag_to_Z_CSp) - if (associated(dd%Kd_itidal)) deallocate(dd%Kd_itidal) if (associated(dd%Kd_lowmode)) deallocate(dd%Kd_lowmode) if (associated(dd%Fl_itidal)) deallocate(dd%Fl_itidal) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index cfcd5ec6c3..31294778b4 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -162,9 +162,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation terms type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure real, dimension(SZIB_(G),SZJ_(G)), & - optional, intent(out) :: taux_bot !< Zonal bottom stress from ocean to rock [Pa] + optional, intent(out) :: taux_bot !< Zonal bottom stress from ocean to rock [kg Z s-2 m-2 ~> Pa] real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to rock [Pa] + optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to rock [kg Z s-2 m-2 ~> Pa] type(wave_parameters_CS), & optional, pointer :: Waves !< Container for wave/Stokes information @@ -1603,110 +1603,110 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! Default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & - "If true, the bottom stress is calculated with a drag \n"//& - "law of the form c_drag*|u|*u. The velocity magnitude \n"//& - "may be an assumed value or it may be based on the \n"//& - "actual velocity in the bottommost HBBL, depending on \n"//& + "If true, the bottom stress is calculated with a drag "//& + "law of the form c_drag*|u|*u. The velocity magnitude "//& + "may be an assumed value or it may be based on the "//& + "actual velocity in the bottommost HBBL, depending on "//& "LINEAR_DRAG.", default=.true.) call get_param(param_file, mdl, "CHANNEL_DRAG", CS%Channel_drag, & - "If true, the bottom drag is exerted directly on each \n"//& - "layer proportional to the fraction of the bottom it \n"//& + "If true, the bottom drag is exerted directly on each "//& + "layer proportional to the fraction of the bottom it "//& "overlies.", default=.false.) call get_param(param_file, mdl, "DIRECT_STRESS", CS%direct_stress, & - "If true, the wind stress is distributed over the \n"//& - "topmost HMIX_STRESS of fluid (like in HYCOM), and KVML \n"//& + "If true, the wind stress is distributed over the "//& + "topmost HMIX_STRESS of fluid (like in HYCOM), and KVML "//& "may be set to a very small value.", default=.false.) call get_param(param_file, mdl, "DYNAMIC_VISCOUS_ML", CS%dynamic_viscous_ML, & - "If true, use a bulk Richardson number criterion to \n"//& + "If true, use a bulk Richardson number criterion to "//& "determine the mixed layer thickness for viscosity.", & default=.false.) call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & - "The absolute path to a file into which the accelerations \n"//& - "leading to zonal velocity truncations are written. \n"//& - "Undefine this for efficiency if this diagnostic is not \n"//& + "The absolute path to a file into which the accelerations "//& + "leading to zonal velocity truncations are written. "//& + "Undefine this for efficiency if this diagnostic is not "//& "needed.", default=" ", debuggingParam=.true.) call get_param(param_file, mdl, "V_TRUNC_FILE", CS%v_trunc_file, & - "The absolute path to a file into which the accelerations \n"//& - "leading to meridional velocity truncations are written. \n"//& - "Undefine this for efficiency if this diagnostic is not \n"//& + "The absolute path to a file into which the accelerations "//& + "leading to meridional velocity truncations are written. "//& + "Undefine this for efficiency if this diagnostic is not "//& "needed.", default=" ", debuggingParam=.true.) call get_param(param_file, mdl, "HARMONIC_VISC", CS%harmonic_visc, & - "If true, use the harmonic mean thicknesses for \n"//& + "If true, use the harmonic mean thicknesses for "//& "calculating the vertical viscosity.", default=.false.) call get_param(param_file, mdl, "HARMONIC_BL_SCALE", CS%harm_BL_val, & - "A scale to determine when water is in the boundary \n"//& - "layers based solely on harmonic mean thicknesses for \n"//& - "the purpose of determining the extent to which the \n"//& + "A scale to determine when water is in the boundary "//& + "layers based solely on harmonic mean thicknesses for "//& + "the purpose of determining the extent to which the "//& "thicknesses used in the viscosities are upwinded.", & default=0.0, units="nondim") call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) if (GV%nkml < 1) & call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & - "The prescribed depth over which the near-surface \n"//& - "viscosity and diffusivity are elevated when the bulk \n"//& + "The prescribed depth over which the near-surface "//& + "viscosity and diffusivity are elevated when the bulk "//& "mixed layer is not used.", units="m", scale=GV%m_to_H, & unscaled=Hmix_m, fail_if_missing=.true.) if (CS%direct_stress) then if (GV%nkml < 1) then call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & - "The depth over which the wind stress is applied if \n"//& + "The depth over which the wind stress is applied if "//& "DIRECT_STRESS is true.", units="m", default=Hmix_m, scale=GV%m_to_H) else call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & - "The depth over which the wind stress is applied if \n"//& + "The depth over which the wind stress is applied if "//& "DIRECT_STRESS is true.", units="m", fail_if_missing=.true., scale=GV%m_to_H) endif if (CS%Hmix_stress <= 0.0) call MOM_error(FATAL, "vertvisc_init: " // & "HMIX_STRESS must be set to a positive value if DIRECT_STRESS is true.") endif call get_param(param_file, mdl, "KV", CS%Kv, & - "The background kinematic viscosity in the interior. \n"//& + "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true., scale=US%m_to_Z**2, unscaled=Kv_dflt) if (GV%nkml < 1) call get_param(param_file, mdl, "KVML", CS%Kvml, & - "The kinematic viscosity in the mixed layer. A typical \n"//& - "value is ~1e-2 m2 s-1. KVML is not used if \n"//& + "The kinematic viscosity in the mixed layer. A typical "//& + "value is ~1e-2 m2 s-1. KVML is not used if "//& "BULKMIXEDLAYER is true. The default is set by KV.", & units="m2 s-1", default=Kv_dflt, scale=US%m_to_Z**2) if (.not.CS%bottomdraglaw) call get_param(param_file, mdl, "KVBBL", CS%Kvbbl, & - "The kinematic viscosity in the benthic boundary layer. \n"//& - "A typical value is ~1e-2 m2 s-1. KVBBL is not used if \n"//& + "The kinematic viscosity in the benthic boundary layer. "//& + "A typical value is ~1e-2 m2 s-1. KVBBL is not used if "//& "BOTTOMDRAGLAW is true. The default is set by KV.", & units="m2 s-1", default=Kv_dflt, scale=US%m_to_Z**2) call get_param(param_file, mdl, "HBBL", CS%Hbbl, & - "The thickness of a bottom boundary layer with a \n"//& - "viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or \n"//& - "the thickness over which near-bottom velocities are \n"//& - "averaged for the drag law if BOTTOMDRAGLAW is defined \n"//& + "The thickness of a bottom boundary layer with a "//& + "viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or "//& + "the thickness over which near-bottom velocities are "//& + "averaged for the drag law if BOTTOMDRAGLAW is defined "//& "but LINEAR_DRAG is not.", units="m", fail_if_missing=.true., scale=GV%m_to_H) call get_param(param_file, mdl, "MAXVEL", CS%maxvel, & - "The maximum velocity allowed before the velocity \n"//& + "The maximum velocity allowed before the velocity "//& "components are truncated.", units="m s-1", default=3.0e8) call get_param(param_file, mdl, "CFL_BASED_TRUNCATIONS", CS%CFL_based_trunc, & - "If true, base truncations on the CFL number, and not an \n"//& + "If true, base truncations on the CFL number, and not an "//& "absolute speed.", default=.true.) call get_param(param_file, mdl, "CFL_TRUNCATE", CS%CFL_trunc, & - "The value of the CFL number that will cause velocity \n"//& + "The value of the CFL number that will cause velocity "//& "components to be truncated; instability can occur past 0.5.", & units="nondim", default=0.5) call get_param(param_file, mdl, "CFL_REPORT", CS%CFL_report, & - "The value of the CFL number that causes accelerations \n"//& + "The value of the CFL number that causes accelerations "//& "to be reported; the default is CFL_TRUNCATE.", & units="nondim", default=CS%CFL_trunc) call get_param(param_file, mdl, "CFL_TRUNCATE_RAMP_TIME", CS%truncRampTime, & - "The time over which the CFL trunction value is ramped\n"//& + "The time over which the CFL truncation value is ramped "//& "up at the beginning of the run.", & units="s", default=0.) CS%CFL_truncE = CS%CFL_trunc call get_param(param_file, mdl, "CFL_TRUNCATE_START", CS%CFL_truncS, & - "The start value of the truncation CFL number used when\n"//& + "The start value of the truncation CFL number used when "//& "ramping up CFL_TRUNC.", & units="nondim", default=0.) call get_param(param_file, mdl, "STOKES_MIXING_COMBINED", CS%StokesMixing, & - "Flag to use Stokes drift Mixing via the Lagrangian \n"//& - " current (Eulerian plus Stokes drift). \n"//& + "Flag to use Stokes drift Mixing via the Lagrangian "//& + " current (Eulerian plus Stokes drift). "//& " Still needs work and testing, so not recommended for use.",& Default=.false.) !BGR 04/04/2018{ @@ -1719,14 +1719,14 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! MOM_error to use, but do so at your own risk and with these points in mind. !} if (CS%StokesMixing) then - call MOM_error(FATAL, "Stokes mixing requires user interfention in the code.\n"//& - " Model now exiting. See MOM_vert_friction.F90 for \n"//& + call MOM_error(FATAL, "Stokes mixing requires user intervention in the code.\n"//& + " Model now exiting. See MOM_vert_friction.F90 for \n"//& " details (search 'BGR 04/04/2018' to locate comment).") endif call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & - "A negligibly small velocity magnitude below which velocity \n"//& - "components are set to 0. A reasonable value might be \n"//& - "1e-30 m/s, which is less than an Angstrom divided by \n"//& + "A negligibly small velocity magnitude below which velocity "//& + "components are set to 0. A reasonable value might be "//& + "1e-30 m/s, which is less than an Angstrom divided by "//& "the age of the universe.", units="m s-1", default=0.0) ALLOC_(CS%a_u(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u(:,:,:) = 0.0 @@ -1769,9 +1769,11 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & if (CS%id_dv_dt_visc > 0) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) CS%id_taux_bot = register_diag_field('ocean_model', 'taux_bot', diag%axesCu1, & - Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa') + Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa', & + conversion=US%Z_to_m) CS%id_tauy_bot = register_diag_field('ocean_model', 'tauy_bot', diag%axesCv1, & - Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa') + Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & + conversion=US%Z_to_m) if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & call PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS%PointAccel_CSp) diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 45eebb983e..d820ecf36a 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -4,7 +4,6 @@ module DOME_tracer ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -93,8 +92,8 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DOME_TRACER_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the DOME tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the DOME tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -104,8 +103,8 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%tracer_IC_file) endif call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 @@ -141,7 +140,7 @@ end function register_DOME_tracer !> Initializes the NTR tracer fields in tr(:,:,:,:) and sets up the tracer output. subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & - sponge_CSp, diag_to_Z_CSp, param_file) + sponge_CSp, param_file) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -155,8 +154,6 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & !! call to DOME_register_tracer. type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure !! for the sponges, if they are in use. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 36bc3edb65..deb8669451 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -11,7 +11,6 @@ module ISOMIP_tracer ! Adapted to the ISOMIP test case by Gustavo Marques, May 2016 use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -97,8 +96,8 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ISOMIP_TRACER_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the ISOMIP tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the ISOMIP tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -108,8 +107,8 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%tracer_IC_file) endif call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 @@ -146,7 +145,7 @@ end function register_ISOMIP_tracer !> Initializes the NTR tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & - ALE_sponge_CSp, diag_to_Z_CSp) + ALE_sponge_CSp) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -164,8 +163,6 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< A pointer to the control structure for !! the sponges, if they are in use. Otherwise this !! may be unassociated. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. real, allocatable :: temp(:,:,:) real, pointer, dimension(:,:,:) :: & diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 805409c16b..7d9ed5f0a4 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -4,7 +4,6 @@ module MOM_OCMIP2_CFC ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -140,7 +139,7 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "CFC_IC_FILE", CS%IC_file, & - "The file in which the CFC initial values can be \n"//& + "The file in which the CFC initial values can be "//& "found, or an empty string for internal initialization.", & default=" ") if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then @@ -153,9 +152,9 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) "If true, CFC_IC_FILE is in depth space, not layer space", & default=.false.) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if tracers are not found in the "//& "restart files of a restarted run.", default=.false.) ! The following vardesc types contain a package of metadata about each tracer, @@ -314,7 +313,7 @@ end subroutine flux_init_OCMIP2_CFC !> Initialize the OCMP2 CFC tracer fields and set up the tracer output. subroutine initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already been !! read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -333,8 +332,6 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS, & type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure for !! the sponges, if they are in use. !! Otherwise this may be unassociated. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. ! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 2b732c5cc3..7c25f5711a 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -20,17 +20,16 @@ module MOM_generic_tracer use g_tracer_utils, only: g_tracer_get_name,g_tracer_set_values,g_tracer_set_common,g_tracer_get_common use g_tracer_utils, only: g_tracer_get_next,g_tracer_type,g_tracer_is_prog,g_tracer_flux_init use g_tracer_utils, only: g_tracer_send_diag,g_tracer_get_values - use g_tracer_utils, only: g_tracer_get_pointer,g_tracer_get_alias,g_diag_type,g_tracer_set_csdiag + use g_tracer_utils, only: g_tracer_get_pointer,g_tracer_get_alias,g_tracer_set_csdiag use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, get_diag_time_end - use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, optics_type use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type - use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc + use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_spatial_means, only : global_area_mean use MOM_sponge, only : set_up_sponge_field, sponge_CS @@ -74,9 +73,6 @@ module MOM_generic_tracer ! The following pointer will be directed to the first element of the ! linked list of generic tracers. type(g_tracer_type), pointer :: g_tracer_list => NULL() - ! The following pointer will be directed to the first element of the - ! linked list of generic diagnostics fields that must be Z registered by MOM. - type(g_diag_type), pointer :: g_diag_list => NULL() integer :: H_to_m !Auxiliary to access GV%H_to_m in routines that do not have access to GV @@ -134,7 +130,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, sub_name, version, "") call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE", CS%IC_file, & - "The file in which the generic trcer initial values can \n"//& + "The file in which the generic trcer initial values can "//& "be found, or an empty string for internal initialization.", & default=" ") if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then @@ -144,12 +140,12 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call log_param(param_file, sub_name, "INPUTDIR/GENERIC_TRACER_IC_FILE", CS%IC_file) endif call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE_IS_Z", CS%Z_IC_file, & - "If true, GENERIC_TRACER_IC_FILE is in depth space, not \n"//& + "If true, GENERIC_TRACER_IC_FILE is in depth space, not "//& "layer space.",default=.false.) call get_param(param_file, sub_name, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if tracers are not found in the "//& "restart files of a restarted run.", default=.false.) CS%restart_CSp => restart_CS @@ -224,7 +220,7 @@ end function register_MOM_generic_tracer !! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, CS, & - sponge_CSp, ALE_sponge_CSp,diag_to_Z_CSp) + sponge_CSp, ALE_sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already been !! read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -240,15 +236,12 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the !! ALE sponges. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. character(len=fm_string_len), parameter :: sub_name = 'initialize_MOM_generic_tracer' logical :: OK integer :: i, j, k, isc, iec, jsc, jec, nk type(g_tracer_type), pointer :: g_tracer,g_tracer_next - type(g_diag_type) , pointer :: g_diag,g_diag_next - character(len=fm_string_len) :: g_tracer_name, longname, units + character(len=fm_string_len) :: g_tracer_name real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr real, dimension(G%isd:G%ied, G%jsd:G%jed,1:G%ke) :: grid_tmask @@ -379,48 +372,6 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, call g_tracer_set_csdiag(CS%diag) #endif - - ! Register Z diagnostic output. - !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& - ": No tracer in the list.") - !For each tracer name get its fields - g_tracer=>CS%g_tracer_list - do - call g_tracer_get_alias(g_tracer,g_tracer_name) - - call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) - tr_ptr => tr_field(:,:,:,1) - call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) - call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) - - call register_Z_tracer(tr_ptr, trim(g_tracer_name),longname , units, & - day, G, diag_to_Z_CSp) - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - - enddo - - !For each special diagnostics name get its fields - !Get the diag list - call generic_tracer_get_diag_list(CS%g_diag_list) - if (associated(CS%g_diag_list)) then - g_diag=>CS%g_diag_list - do - if (g_diag%Z_diag /= 0) & - call register_Z_tracer(g_diag%field_ptr, trim(g_diag%name),g_diag%longname , g_diag%units, & - day, G, diag_to_Z_CSp) - - !traverse the linked list till hit NULL - g_diag=>g_diag%next - if (.NOT. associated(g_diag)) exit - - enddo - endif - CS%H_to_m = GV%H_to_m end subroutine initialize_MOM_generic_tracer diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index d5a6f45c5f..deeb9529ee 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -137,54 +137,54 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "NDIFF_CONTINUOUS", CS%continuous_reconstruction, & - "If true, uses a continuous reconstruction of T and S when \n"// & - "finding neutral surfaces along which diffusion will happen.\n"// & - "If false, a PPM discontinuous reconstruction of T and S \n"// & - "is done which results in a higher order routine but exacts \n"// & + "If true, uses a continuous reconstruction of T and S when "//& + "finding neutral surfaces along which diffusion will happen. "//& + "If false, a PPM discontinuous reconstruction of T and S "//& + "is done which results in a higher order routine but exacts "//& "a higher computational cost.", default=.true.) call get_param(param_file, mdl, "NDIFF_REF_PRES", CS%ref_pres, & - "The reference pressure (Pa) used for the derivatives of \n"// & - "the equation of state. If negative (default), local \n"// & + "The reference pressure (Pa) used for the derivatives of "//& + "the equation of state. If negative (default), local "//& "pressure is used.", & default = -1.) ! Initialize and configure remapping if (CS%continuous_reconstruction .eqv. .false.) then call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & - "Uses a rootfinding approach to find the position of a\n"// & - "neutral surface within a layer taking into account the\n"// & - "nonlinearity of the equation of state and the\n"// & + "Uses a rootfinding approach to find the position of a "//& + "neutral surface within a layer taking into account the "//& + "nonlinearity of the equation of state and the "//& "polynomial reconstructions of T/S.", & default=.false.) call get_param(param_file, mdl, "NDIFF_REMAPPING_SCHEME", string, & - "This sets the reconstruction scheme used\n"//& - "for vertical remapping for all variables.\n"//& - "It can be one of the following schemes:\n"//& + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "NDIFF_REFINE_POSITION", CS%refine_position, & - "Uses a rootfinding approach to find the position of a\n"// & - "neutral surface within a layer taking into account the\n"// & - "nonlinearity of the equation of state and the\n"// & + "Uses a rootfinding approach to find the position of a "//& + "neutral surface within a layer taking into account the "//& + "nonlinearity of the equation of state and the "//& "polynomial reconstructions of T/S.", & default=.false.) if (CS%refine_position) then call get_param(param_file, mdl, "NDIFF_DRHO_TOL", drho_tol, & - "Sets the convergence criterion for finding the neutral\n"// & + "Sets the convergence criterion for finding the neutral "//& "position within a layer in kg m-3.", & default=1.e-10) call get_param(param_file, mdl, "NDIFF_X_TOL", xtol, & - "Sets the convergence criterion for a change in nondim\n"// & + "Sets the convergence criterion for a change in nondim "//& "position within a layer.", & default=0.) call get_param(param_file, mdl, "NDIFF_MAX_ITER", max_iter, & - "The maximum number of iterations to be done before \n"// & + "The maximum number of iterations to be done before "//& "exiting the iterative loop to find the neutral surface", & default=10) call set_ndiff_aux_params(CS%ndiff_aux_CS, max_iter = max_iter, drho_tol = drho_tol, xtol = xtol) endif call get_param(param_file, mdl, "NDIFF_DEBUG", CS%debug, & - "Turns on verbose output for discontinuous neutral \n"// & + "Turns on verbose output for discontinuous neutral "//& "diffusion routines.", & default = .false.) call set_ndiff_aux_params(CS%ndiff_aux_CS, deg=CS%deg, ref_pres = CS%ref_pres, EOS = EOS, debug = CS%debug) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index a4676583bd..00b61210fe 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -1313,27 +1313,27 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV) call get_param(param_file, mdl, "DT_OFFLINE", CS%dt_offline, & "Length of time between reading in of input fields", fail_if_missing = .true.) call get_param(param_file, mdl, "DT_OFFLINE_VERTICAL", CS%dt_offline_vertical, & - "Length of the offline timestep for tracer column sources/sinks\n" //& - "This should be set to the length of the coupling timestep for \n" //& + "Length of the offline timestep for tracer column sources/sinks " //& + "This should be set to the length of the coupling timestep for " //& "tracers which need shortwave fluxes", fail_if_missing = .true.) call get_param(param_file, mdl, "START_INDEX", CS%start_index, & "Which time index to start from", default=1) call get_param(param_file, mdl, "FIELDS_ARE_OFFSET", CS%fields_are_offset, & - "True if the time-averaged fields and snapshot fields\n"//& + "True if the time-averaged fields and snapshot fields "//& "are offset by one time level", default=.false.) call get_param(param_file, mdl, "REDISTRIBUTE_METHOD", redistribute_method, & - "Redistributes any remaining horizontal fluxes throughout\n" //& - "the rest of water column. Options are 'barotropic' which\n" //& - "evenly distributes flux throughout the entire water column,\n" //& - "'upwards' which adds the maximum of the remaining flux in\n" //& - "each layer above, both which first applies upwards and then\n" //& + "Redistributes any remaining horizontal fluxes throughout " //& + "the rest of water column. Options are 'barotropic' which " //& + "evenly distributes flux throughout the entire water column, " //& + "'upwards' which adds the maximum of the remaining flux in " //& + "each layer above, both which first applies upwards and then " //& "barotropic, and 'none' which does no redistribution", & default='barotropic') call get_param(param_file, mdl, "NUM_OFF_ITER", CS%num_off_iter, & "Number of iterations to subdivide the offline tracer advection and diffusion", & default = 60) call get_param(param_file, mdl, "OFF_ALE_MOD", CS%off_ale_mod, & - "Sets how many horizontal advection steps are taken before an ALE\n" //& + "Sets how many horizontal advection steps are taken before an ALE " //& "remapping step is done. 1 would be x->y->ALE, 2 would be" //& "x->y->x->y->ALE", default = 1) call get_param(param_file, mdl, "PRINT_ADV_OFFLINE", CS%print_adv_offline, & @@ -1350,21 +1350,21 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV) "Name of the variable containing the depth of active mixing",& default='ePBL_h_ML') call get_param(param_file, mdl, "OFFLINE_ADD_DIURNAL_SW", CS%diurnal_sw, & - "Adds a synthetic diurnal cycle in the same way that the ice\n" // & - "model would have when time-averaged fields of shortwave\n" // & + "Adds a synthetic diurnal cycle in the same way that the ice " // & + "model would have when time-averaged fields of shortwave " // & "radiation are read in", default=.false.) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & - "The maximum permitted increment for the diapycnal \n"//& - "diffusivity from TKE-based parameterizations, or a \n"//& + "The maximum permitted increment for the diapycnal "//& + "diffusivity from TKE-based parameterizations, or a "//& "negative value for no limit.", units="m2 s-1", default=-1.0) call get_param(param_file, mdl, "MIN_RESIDUAL_TRANSPORT", CS%min_residual, & - "How much remaining transport before the main offline advection\n"// & - "is exited. The default value corresponds to about 1 meter of\n" // & + "How much remaining transport before the main offline advection "// & + "is exited. The default value corresponds to about 1 meter of " // & "difference in a grid cell", default = 1.e9) call get_param(param_file, mdl, "READ_ALL_TS_UVH", CS%read_all_ts_uvh, & - "Reads all time levels of a subset of the fields necessary to run \n" // & - "the model offline. This can require a large amount of memory\n"// & - "and will make initialization very slow. However, for offline\n"// & + "Reads all time levels of a subset of the fields necessary to run " // & + "the model offline. This can require a large amount of memory "// & + "and will make initialization very slow. However, for offline "// & "runs spanning more than a year this can reduce total I/O overhead", & default = .false.) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index dd44fb15b2..02275d7ad9 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -3,7 +3,7 @@ module MOM_tracer_Z_init ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_diag_to_Z, only : find_overlap, find_limited_slope +!use MOM_diag_to_Z, only : find_overlap, find_limited_slope use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe ! use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -401,5 +401,103 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & end subroutine read_Z_edges +!### `find_overlap` and `find_limited_slope` were previously part of +! MOM_diag_to_Z.F90, and are nearly identical to `find_overlap` in +! `midas_vertmap.F90` with some slight differences. We keep it here for +! reproducibility, but the two should be merged at some point + +!> Determines the layers bounded by interfaces e that overlap +!! with the depth range between Z_top and Z_bot, and the fractional weights +!! of each layer. It also calculates the normalized relative depths of the range +!! of each layer that overlaps that depth range. + +! ### TODO: Merge with midas_vertmap.F90:find_overlap() +subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z2) + real, dimension(:), intent(in) :: e !< Column interface heights, in arbitrary units. + real, intent(in) :: Z_top !< Top of range being mapped to, in the units of e. + real, intent(in) :: Z_bot !< Bottom of range being mapped to, in the units of e. + integer, intent(in) :: k_max !< Number of valid layers. + integer, intent(in) :: k_start !< Layer at which to start searching. + integer, intent(inout) :: k_top !< Indices of top layers that overlap with the depth + !! range. + integer, intent(inout) :: k_bot !< Indices of bottom layers that overlap with the + !! depth range. + real, dimension(:), intent(out) :: wt !< Relative weights of each layer from k_top to k_bot. + real, dimension(:), intent(out) :: z1 !< Depth of the top limits of the part of + !! a layer that contributes to a depth level, relative to the cell center and normalized + !! by the cell thickness [nondim]. Note that -1/2 <= z1 < z2 <= 1/2. + real, dimension(:), intent(out) :: z2 !< Depths of the bottom limit of the part of + !! a layer that contributes to a depth level, relative to the cell center and normalized + !! by the cell thickness [nondim]. Note that -1/2 <= z1 < z2 <= 1/2. + ! Local variables + real :: Ih, e_c, tot_wt, I_totwt + integer :: k + + do k=k_start,k_max ; if (e(K+1)k_max) return + + ! Determine the fractional weights of each layer. + ! Note that by convention, e and Z_int decrease with increasing k. + if (e(K+1)<=Z_bot) then + wt(k) = 1.0 ; k_bot = k + Ih = 0.0 ; if (e(K) /= e(K+1)) Ih = 1.0 / (e(K)-e(K+1)) + e_c = 0.5*(e(K)+e(K+1)) + z1(k) = (e_c - MIN(e(K),Z_top)) * Ih + z2(k) = (e_c - Z_bot) * Ih + else + wt(k) = MIN(e(K),Z_top) - e(K+1) ; tot_wt = wt(k) ! These are always > 0. + if (e(K) /= e(K+1)) then + z1(k) = (0.5*(e(K)+e(K+1)) - MIN(e(K), Z_top)) / (e(K)-e(K+1)) + else ; z1(k) = -0.5 ; endif + z2(k) = 0.5 + k_bot = k_max + do k=k_top+1,k_max + if (e(K+1)<=Z_bot) then + k_bot = k + wt(k) = e(K) - Z_bot ; z1(k) = -0.5 + if (e(K) /= e(K+1)) then + z2(k) = (0.5*(e(K)+e(K+1)) - Z_bot) / (e(K)-e(K+1)) + else ; z2(k) = 0.5 ; endif + else + wt(k) = e(K) - e(K+1) ; z1(k) = -0.5 ; z2(k) = 0.5 + endif + tot_wt = tot_wt + wt(k) ! wt(k) is always > 0. + if (k>=k_bot) exit + enddo + + I_totwt = 1.0 / tot_wt + do k=k_top,k_bot ; wt(k) = I_totwt*wt(k) ; enddo + endif + +end subroutine find_overlap + +!> This subroutine determines a limited slope for val to be advected with +!! a piecewise limited scheme. +! ### TODO: Merge with midas_vertmap.F90:find_limited_slope() +subroutine find_limited_slope(val, e, slope, k) + real, dimension(:), intent(in) :: val !< A column of values that are being interpolated. + real, dimension(:), intent(in) :: e !< Column interface heights in arbitrary units + real, intent(out) :: slope !< Normalized slope in the intracell distribution of val. + integer, intent(in) :: k !< Layer whose slope is being determined. + ! Local variables + real :: d1, d2 ! Thicknesses in the units of e. + + d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) + if (((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) .or. (d1*d2 <= 0.0)) then + slope = 0.0 ! ; curvature = 0.0 + else + slope = (d1**2*(val(k+1) - val(k)) + d2**2*(val(k) - val(k-1))) * & + ((e(K) - e(K+1)) / (d1*d2*(d1+d2))) + ! slope = 0.5*(val(k+1) - val(k-1)) + ! This is S.J. Lin's form of the PLM limiter. + slope = sign(1.0,slope) * min(abs(slope), & + 2.0*(max(val(k-1),val(k),val(k+1)) - val(k)), & + 2.0*(val(k) - min(val(k-1),val(k),val(k+1)))) + ! curvature = 0.0 + endif + +end subroutine find_limited_slope + end module MOM_tracer_Z_init diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index a3c75bd7fd..d937f27d92 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -4,7 +4,6 @@ module MOM_tracer_flow_control ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : time_type, diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type, close_param_file use MOM_forcing_type, only : forcing, optics_type @@ -31,6 +30,9 @@ module MOM_tracer_flow_control use ISOMIP_tracer, only : register_ISOMIP_tracer, initialize_ISOMIP_tracer use ISOMIP_tracer, only : ISOMIP_tracer_column_physics, ISOMIP_tracer_surface_state use ISOMIP_tracer, only : ISOMIP_tracer_end, ISOMIP_tracer_CS +use RGC_tracer, only : register_RGC_tracer, initialize_RGC_tracer +use RGC_tracer, only : RGC_tracer_column_physics +use RGC_tracer, only : RGC_tracer_end, RGC_tracer_CS use ideal_age_example, only : register_ideal_age_tracer, initialize_ideal_age_tracer use ideal_age_example, only : ideal_age_tracer_column_physics, ideal_age_tracer_surface_state use ideal_age_example, only : ideal_age_stock, ideal_age_example_end, ideal_age_tracer_CS @@ -74,6 +76,7 @@ module MOM_tracer_flow_control logical :: use_USER_tracer_example = .false. !< If true, use the USER_tracer_example package logical :: use_DOME_tracer = .false. !< If true, use the DOME_tracer package logical :: use_ISOMIP_tracer = .false. !< If true, use the ISOMPE_tracer package + logical :: use_RGC_tracer =.false. !< If true, use the RGC_tracer package logical :: use_ideal_age = .false. !< If true, use the ideal age tracer package logical :: use_regional_dyes = .false. !< If true, use the regional dyes tracer package logical :: use_oil = .false. !< If true, use the oil tracer package @@ -87,6 +90,7 @@ module MOM_tracer_flow_control type(USER_tracer_example_CS), pointer :: USER_tracer_example_CSp => NULL() type(DOME_tracer_CS), pointer :: DOME_tracer_CSp => NULL() type(ISOMIP_tracer_CS), pointer :: ISOMIP_tracer_CSp => NULL() + type(RGC_tracer_CS), pointer :: RGC_tracer_CSp => NULL() type(ideal_age_tracer_CS), pointer :: ideal_age_tracer_CSp => NULL() type(dye_tracer_CS), pointer :: dye_tracer_CSp => NULL() type(oil_tracer_CS), pointer :: oil_tracer_CSp => NULL() @@ -187,6 +191,9 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) call get_param(param_file, mdl, "USE_ISOMIP_TRACER", CS%use_ISOMIP_tracer, & "If true, use the ISOMIP_tracer tracer package.", & default=.false.) + call get_param(param_file, mdl, "USE_RGC_TRACER", CS%use_RGC_tracer, & + "If true, use the RGC_tracer tracer package.", & + default=.false.) call get_param(param_file, mdl, "USE_IDEAL_AGE_TRACER", CS%use_ideal_age, & "If true, use the ideal_age_example tracer package.", & default=.false.) @@ -202,9 +209,8 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) call get_param(param_file, mdl, "USE_OCMIP2_CFC", CS%use_OCMIP2_CFC, & "If true, use the MOM_OCMIP2_CFC tracer package.", & default=.false.) - call get_param(param_file, mdl, "USE_generic_tracer", & - CS%use_MOM_generic_tracer, & - "If true and _USE_GENERIC_TRACER is defined as a \n"//& + call get_param(param_file, mdl, "USE_generic_tracer", CS%use_MOM_generic_tracer, & + "If true and _USE_GENERIC_TRACER is defined as a "//& "preprocessor macro, use the MOM_generic_tracer packages.", & default=.false.) call get_param(param_file, mdl, "USE_PSEUDO_SALT_TRACER", CS%use_pseudo_salt_tracer, & @@ -235,6 +241,9 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) if (CS%use_ISOMIP_tracer) CS%use_ISOMIP_tracer = & register_ISOMIP_tracer(HI, GV, param_file, CS%ISOMIP_tracer_CSp, & tr_Reg, restart_CS) + if (CS%use_RGC_tracer) CS%use_RGC_tracer = & + register_RGC_tracer(HI, GV, param_file, CS%RGC_tracer_CSp, & + tr_Reg, restart_CS) if (CS%use_ideal_age) CS%use_ideal_age = & register_ideal_age_tracer(HI, GV, param_file, CS%ideal_age_tracer_CSp, & tr_Reg, restart_CS) @@ -271,7 +280,7 @@ end subroutine call_tracer_register !> This subroutine calls all registered tracer initialization !! subroutines. subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag, OBC, & - CS, sponge_CSp, ALE_sponge_CSp, diag_to_Z_CSp, tv) + CS, sponge_CSp, ALE_sponge_CSp, tv) logical, intent(in) :: restart !< 1 if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -297,8 +306,6 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< A pointer to the control !! structure for the ALE sponges, if they are in use. !! Otherwise this may be unassociated. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control - !! structure for diagnostics in depth space. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables @@ -308,42 +315,44 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag ! Add other user-provided calls here. if (CS%use_USER_tracer_example) & call USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS%USER_tracer_example_CSp, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) if (CS%use_DOME_tracer) & call initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS%DOME_tracer_CSp, & - sponge_CSp, diag_to_Z_CSp, param_file) + sponge_CSp, param_file) if (CS%use_ISOMIP_tracer) & call initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS%ISOMIP_tracer_CSp, & - ALE_sponge_CSp, diag_to_Z_CSp) + ALE_sponge_CSp) + if (CS%use_RGC_tracer) & + call initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, & + CS%RGC_tracer_CSp, sponge_CSp, ALE_sponge_CSp) if (CS%use_ideal_age) & call initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS%ideal_age_tracer_CSp, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) if (CS%use_regional_dyes) & call initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS%dye_tracer_CSp, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) if (CS%use_oil) & call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) if (CS%use_advection_test_tracer) & call initialize_advection_test_tracer(restart, day, G, GV, h, diag, OBC, CS%advection_test_tracer_CSp, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) if (CS%use_OCMIP2_CFC) & call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, & - CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp, diag_to_Z_CSp) + CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) #endif if (CS%use_pseudo_salt_tracer) & call initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & - sponge_CSp, diag_to_Z_CSp, tv) + sponge_CSp, tv) if (CS%use_boundary_impulse_tracer) & call initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, CS%boundary_impulse_tracer_CSp, & - sponge_CSp, diag_to_Z_CSp, tv) + sponge_CSp, tv) if (CS%use_dyed_obc_tracer) & - call initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS%dyed_obc_tracer_CSp, & - diag_to_Z_CSp) + call initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS%dyed_obc_tracer_CSp) end subroutine tracer_flow_control_init @@ -453,6 +462,11 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, CS%ISOMIP_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) + if (CS%use_RGC_tracer) & + call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, CS%RGC_tracer_CSp, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, CS%ideal_age_tracer_CSp, & @@ -513,6 +527,9 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, if (CS%use_ISOMIP_tracer) & call ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, CS%ISOMIP_tracer_CSp) + if (CS%use_RGC_tracer) & + call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, CS%RGC_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, CS%ideal_age_tracer_CSp) @@ -780,6 +797,7 @@ subroutine tracer_flow_control_end(CS) call USER_tracer_example_end(CS%USER_tracer_example_CSp) if (CS%use_DOME_tracer) call DOME_tracer_end(CS%DOME_tracer_CSp) if (CS%use_ISOMIP_tracer) call ISOMIP_tracer_end(CS%ISOMIP_tracer_CSp) + if (CS%use_RGC_tracer) call RGC_tracer_end(CS%RGC_tracer_CSp) if (CS%use_ideal_age) call ideal_age_example_end(CS%ideal_age_tracer_CSp) if (CS%use_regional_dyes) call regional_dyes_end(CS%dye_tracer_CSp) if (CS%use_oil) call oil_tracer_end(CS%oil_tracer_CSp) @@ -798,6 +816,7 @@ end subroutine tracer_flow_control_end !> \namespace MOM_tracer_flow_control !! !! By Will Cooke, April 2003 +!! Edited by Elizabeth Yankovsky, May 2019 !! !! This module contains two subroutines into which calls to other !! tracer initialization (call_tracer_init_fns) and column physics diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 48ec698696..261d8d1315 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1403,8 +1403,8 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) "The background along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", CS%KhTr_Slope_Cff, & - "The scaling coefficient for along-isopycnal tracer \n"//& - "diffusivity using a shear-based (Visbeck-like) \n"//& + "The scaling coefficient for along-isopycnal tracer "//& + "diffusivity using a shear-based (Visbeck-like) "//& "parameterization. A non-zero value enables this param.", & units="nondim", default=0.0) call get_param(param_file, mdl, "KHTR_MIN", CS%KhTr_Min, & @@ -1414,34 +1414,34 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) "The maximum along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0) call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", CS%KhTr_passivity_coeff, & - "The coefficient that scales deformation radius over \n"//& - "grid-spacing in passivity, where passiviity is the ratio \n"//& - "between along isopycnal mxiing of tracers to thickness mixing. \n"//& + "The coefficient that scales deformation radius over "//& + "grid-spacing in passivity, where passivity is the ratio "//& + "between along isopycnal mixing of tracers to thickness mixing. "//& "A non-zero value enables this parameterization.", & units="nondim", default=0.0) call get_param(param_file, mdl, "KHTR_PASSIVITY_MIN", CS%KhTr_passivity_min, & - "The minimum passivity which is the ratio between \n"//& - "along isopycnal mxiing of tracers to thickness mixing. \n", & + "The minimum passivity which is the ratio between "//& + "along isopycnal mixing of tracers to thickness mixing.", & units="nondim", default=0.5) call get_param(param_file, mdl, "DIFFUSE_ML_TO_INTERIOR", CS%Diffuse_ML_interior, & - "If true, enable epipycnal mixing between the surface \n"//& + "If true, enable epipycnal mixing between the surface "//& "boundary layer and the interior.", default=.false.) call get_param(param_file, mdl, "CHECK_DIFFUSIVE_CFL", CS%check_diffusive_CFL, & - "If true, use enough iterations the diffusion to ensure \n"//& - "that the diffusive equivalent of the CFL limit is not \n"//& - "violated. If false, always use the greater of 1 or \n"//& + "If true, use enough iterations the diffusion to ensure "//& + "that the diffusive equivalent of the CFL limit is not "//& + "violated. If false, always use the greater of 1 or "//& "MAX_TR_DIFFUSION_CFL iteration.", default=.false.) call get_param(param_file, mdl, "MAX_TR_DIFFUSION_CFL", CS%max_diff_CFL, & - "If positive, locally limit the along-isopycnal tracer \n"//& - "diffusivity to keep the diffusive CFL locally at or \n"//& - "below this value. The number of diffusive iterations \n"//& + "If positive, locally limit the along-isopycnal tracer "//& + "diffusivity to keep the diffusive CFL locally at or "//& + "below this value. The number of diffusive iterations "//& "is often this value or the next greater integer.", & units="nondim", default=-1.0) CS%ML_KhTR_scale = 1.0 if (CS%Diffuse_ML_interior) then call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & - "With Diffuse_ML_interior, the ratio of the truly \n"//& - "horizontal diffusivity in the mixed layer to the \n"//& + "With Diffuse_ML_interior, the ratio of the truly "//& + "horizontal diffusivity in the mixed layer to the "//& "epipycnal diffusivity. The valid range is 0 to 1.", & units="nondim", default=1.0) endif diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index f5c7d65f03..cbaf18d983 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -12,7 +12,6 @@ module MOM_tracer_registry use MOM_diag_mediator, only : diag_ctrl, register_diag_field, post_data, safe_alloc_ptr use MOM_diag_mediator, only : diag_grid_storage use MOM_diag_mediator, only : diag_copy_storage_to_diag, diag_save_grids, diag_restore_grids -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_hor_index, only : hor_index_type @@ -321,7 +320,7 @@ end subroutine lock_tracer_registry !> register_tracer_diagnostics does a set of register_diag_field calls for any previously !! registered in a tracer registry with a value of registry_diags set to .true. -subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_to_Z_CSp) +subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry @@ -331,8 +330,6 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output logical, intent(in) :: use_ALE !< If true active diagnostics that only !! apply to ALE configurations - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. character(len=24) :: name ! A variable's name in a NetCDF file. character(len=24) :: shortnm ! A shortened version of a variable's name for @@ -528,14 +525,6 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ enddo ; enddo ; enddo endif - if (len_trim(cmorname) == 0) then - call register_Z_tracer(Tr%t, name, longname, units, Time, G, diag_to_Z_CSp) - else - call register_Z_tracer(Tr%t, name, longname, units, Time, G, diag_to_Z_CSp, & - cmor_field_name=cmorname, cmor_standard_name=cmor_long_std(cmor_longname), & - cmor_long_name=cmor_longname) - endif - ! Vertical regridding/remapping tendencies if (use_ALE .and. Tr%remap_tr) then var_lname = "Vertical remapping tracer concentration tendency for "//trim(Reg%Tr(m)%name) diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 new file mode 100644 index 0000000000..decb834a6a --- /dev/null +++ b/src/tracer/RGC_tracer.F90 @@ -0,0 +1,353 @@ +!> This module contains the routines used to set up a +!! dynamically passive tracer. +!! Set up and use passive tracers requires the following: +!! (1) register_RGC_tracer +!! (2) apply diffusion, physics/chemistry and advect the tracer + +!********+*********+*********+*********+*********+*********+*********+** +!* * +!* By Elizabeth Yankovsky, June 2019 * +!*********+*********+*********+*********+*********+*********+*********** + +module RGC_tracer + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_restart, only : MOM_restart_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS, get_ALE_sponge_nz_data +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_variables, only : surface +use MOM_open_boundary, only : ocean_OBC_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!< Publicly available functions +public register_RGC_tracer, initialize_RGC_tracer +public RGC_tracer_column_physics, RGC_tracer_end + +integer, parameter :: NTR = 1 !< The number of tracers in this module. + +!> tracer control structure +type, public :: RGC_tracer_CS ; private + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + character(len = 200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package. + real, pointer :: tr_aux(:,:,:,:) => NULL() !< The masked tracer concentration. + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + real :: lenlat !< the latitudinal or y-direction length of the domain. + real :: lenlon !< the longitudinal or x-direction length of the domain. + real :: CSL !< The length of the continental shelf (x dir, km) + real :: lensponge !< the length of the sponge layer. + logical :: mask_tracers !< If true, tracers are masked out in massless layers. + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. + type(vardesc) :: tr_desc(NTR) !< Descriptions and metadata for the tracers. +end type RGC_tracer_CS + +contains + + +!> This subroutine is used to register tracer fields +function register_RGC_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file ! NULL() + logical :: register_RGC_tracer + integer :: isd, ied, jsd, jed, nz, m + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(WARNING, "RGC_register_tracer called with an "// & + "associated control structure.") + return + endif + allocate(CS) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "RGC_TRACER_IC_FILE", CS%tracer_IC_file, & + "The name of a file from which to read the initial \n"//& + "conditions for the RGC tracers, or blank to initialize \n"//& + "them internally.", default=" ") + if (len_trim(CS%tracer_IC_file) >= 1) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + CS%tracer_IC_file = trim(inputdir)//trim(CS%tracer_IC_file) + call log_param(param_file, mdl, "INPUTDIR/RGC_TRACER_IC_FILE", & + CS%tracer_IC_file) + endif + call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & + "If true, sponges may be applied anywhere in the domain. \n"//& + "The exact location and properties of those sponges are \n"//& + "specified from MOM_initialization.F90.", default=.false.) + + call get_param(param_file, mdl, "LENLAT", CS%lenlat, & + "The latitudinal or y-direction length of the domain", & + fail_if_missing=.true., do_not_log=.true.) + + call get_param(param_file, mdl, "LENLON", CS%lenlon, & + "The longitudinal or x-direction length of the domain", & + fail_if_missing=.true., do_not_log=.true.) + + call get_param(param_file, mdl, "CONT_SHELF_LENGTH", CS%CSL, & + "The length of the continental shelf (x dir, km).", & + default=15.0) + + call get_param(param_file, mdl, "LENSPONGE", CS%lensponge, & + "The length of the sponge layer (km).", & + default=10.0) + + allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 + if (CS%mask_tracers) then + allocate(CS%tr_aux(isd:ied,jsd:jed,nz,NTR)) ; CS%tr_aux(:,:,:,:) = 0.0 + endif + + do m=1,NTR + if (m < 10) then ; write(name,'("tr_RGC",I1.1)') m + else ; write(name,'("tr_RGC",I2.2)') m ; endif + write(longname,'("Concentration of RGC Tracer ",I2.2)') m + CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + + ! This is needed to force the compiler not to do a copy in the registration calls. + tr_ptr => CS%tr(:,:,:,m) + ! Register the tracer for horizontal advection & diffusion. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units="kg/s", & + restart_CS=restart_CS) + enddo + + CS%tr_Reg => tr_Reg + register_RGC_tracer = .true. +end function register_RGC_tracer + +!> Initializes the NTR tracer fields in tr(:,:,:,:) +!! and it sets up the tracer output. +subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & + layer_CSp, sponge_CSp) + + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness, in m or kg m-2. + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. This is not being used for now. + type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to RGC_register_tracer. + type(sponge_CS), pointer :: layer_CSp !< A pointer to the control structure + type(ALE_sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure for the + !! sponges, if they are in use. Otherwise this may be unassociated. + + real, allocatable :: temp(:,:,:) + real, pointer, dimension(:,:,:) :: & + OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to + OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come + ! in through u- and v- points through the open + ! boundary conditions, in the same units as tr. + character(len=16) :: name ! A variable's name in a NetCDF file. + character(len=72) :: longname ! The long name of that variable. + character(len=48) :: units ! The dimensions of the variable. + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. + real, pointer :: tr_ptr(:,:,:) => NULL() + real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: tr_y ! Initial zonally uniform tracer concentrations. + real :: dist2 ! The distance squared from a line, in m2. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected, in m. + real :: e(SZK_(G)+1), e_top, e_bot, d_tr ! Heights [Z ~> m]. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: IsdB, IedB, JsdB, JedB + integer :: nzdata + + if (.not.associated(CS)) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + h_neglect = GV%H_subroundoff + + CS%Time => day + CS%diag => diag + + if (.not.restart) then + if (len_trim(CS%tracer_IC_file) >= 1) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & + call MOM_error(FATAL, "RGC_initialize_tracer: Unable to open "// & + CS%tracer_IC_file) + do m=1,NTR + call query_vardesc(CS%tr_desc(m), name, caller="initialize_RGC_tracer") + call read_data(CS%tracer_IC_file, trim(name), & + CS%tr(:,:,:,m), domain=G%Domain%mpp_domain) + enddo + else + do m=1,NTR + do k=1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = 0.0 + enddo ; enddo ; enddo + enddo + m=1 + do j=js,je ; do i=is,ie + !set tracer to 1.0 in the surface of the continental shelf + if (G%geoLonT(i,j) <= (CS%CSL)) then + CS%tr(i,j,1,m) = 1.0 !first layer + endif + enddo ; enddo + + endif + endif ! restart + + if ( CS%use_sponge ) then +! If sponges are used, this damps values to zero in the offshore boundary. +! For any tracers that are not damped in the sponge, the call +! to set_up_sponge_field can simply be omitted. + if (associated(sponge_CSp)) then !ALE mode + nzdata = get_ALE_sponge_nz_data(sponge_CSp) + if (nzdata>0) then + allocate(temp(G%isd:G%ied,G%jsd:G%jed,nzdata)) + do k=1,nzdata ; do j=js,je ; do i=is,ie + if (G%geoLonT(i,j) >= (CS%lenlon - CS%lensponge) .AND. G%geoLonT(i,j) <= CS%lenlon) then + temp(i,j,k) = 0.0 + endif + enddo ; enddo; enddo + do m=1,1 + ! This is needed to force the compiler not to do a copy in the sponge calls. + tr_ptr => CS%tr(:,:,:,m) + call set_up_ALE_sponge_field(temp, G, tr_ptr, sponge_CSp) + enddo + deallocate(temp) + endif + + elseif (associated(layer_CSp)) then !layer mode + if (nz>0) then + allocate(temp(G%isd:G%ied,G%jsd:G%jed,nz)) + do k=1,nz ; do j=js,je ; do i=is,ie + if (G%geoLonT(i,j) >= (CS%lenlon - CS%lensponge) .AND. G%geoLonT(i,j) <= CS%lenlon) then + temp(i,j,k) = 0.0 + endif + enddo ; enddo; enddo + do m=1,1 + tr_ptr => CS%tr(:,:,:,m) + call set_up_sponge_field(temp, tr_ptr, G, nz, layer_CSp) + enddo + deallocate(temp) + endif + else + call MOM_error(FATAL, "RGC_initialize_tracer: "// & + "The pointer to sponge_CSp must be associated if SPONGE is defined.") + endif !selecting mode/calling error if no pointer + endif !using sponge + +end subroutine initialize_RGC_tracer + +!> This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +!! This is a simple example of a set of advected passive tracers. +subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible + !! forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s]. + type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can be + !! fluxed out of the top layer in a timestep [nondim]. + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes + !! can be applied [m]. + +! The arguments to this subroutine are redundant in that +! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] + + real :: b1(SZI_(G)) ! b1 and c1 are variables used by the + real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified + real :: in_flux(SZI_(G),SZJ_(G),2) ! total amount of tracer to be injected + + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + if (.not.associated(CS)) return + + in_flux(:,:,:) = 0.0 + m=1 + do j=js,je ; do i=is,ie + !set tracer to 1.0 in the surface of the continental shelf + if (G%geoLonT(i,j) <= (CS%CSL)) then + CS%tr(i,j,1,m) = 1.0 !first layer + endif + enddo ; enddo + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,NTR + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo; + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth, in_flux(:,:,m)) + + call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + else + do m=1,NTR + call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + enddo + endif + +end subroutine RGC_tracer_column_physics + +subroutine RGC_tracer_end(CS) + type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call to RGC_register_tracer. + integer :: m + + if (associated(CS)) then + if (associated(CS%tr)) deallocate(CS%tr) + deallocate(CS) + endif +end subroutine RGC_tracer_end + +end module RGC_tracer diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 34f788c952..4db1e9dacd 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -4,7 +4,6 @@ module advection_test_tracer ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -99,16 +98,16 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ADVECTION_TEST_X_ORIGIN", CS%x_origin, & - "The x-coorindate of the center of the test-functions.\n", default=0.) + "The x-coorindate of the center of the test-functions.", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_ORIGIN", CS%y_origin, & - "The y-coorindate of the center of the test-functions.\n", default=0.) + "The y-coorindate of the center of the test-functions.", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_X_WIDTH", CS%x_width, & - "The x-width of the test-functions.\n", default=0.) + "The x-width of the test-functions.", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_WIDTH", CS%y_width, & - "The y-width of the test-functions.\n", default=0.) + "The y-width of the test-functions.", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_TRACER_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then @@ -118,14 +117,14 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ CS%tracer_IC_file) endif call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if the tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& "restart files of a restarted run.", default=.false.) @@ -164,7 +163,7 @@ end function register_advection_test_tracer !> Initializes the NTR tracer fields in tr(:,:,:,:) and it sets up the tracer output. subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -180,8 +179,6 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. ! Local variables real, allocatable :: temp(:,:,:) diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index fa95d8aa77..946a5f981f 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -4,7 +4,6 @@ module boundary_impulse_tracer ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -99,14 +98,14 @@ function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restar ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "IMPULSE_SOURCE_TIME", CS%remaining_source_time, & - "Length of time for the boundary tracer to be injected\n"//& - "into the mixed layer. After this time has elapsed, the\n"//& + "Length of time for the boundary tracer to be injected "//& + "into the mixed layer. After this time has elapsed, the "//& "surface becomes a sink for the boundary impulse tracer.", & default=31536000.0) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if the tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& "restart files of a restarted run.", default=.false.) CS%ntr = NTR_MAX allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 @@ -149,7 +148,7 @@ end function register_boundary_impulse_tracer !> Initialize tracer from restart or set to 1 at surface to initialize subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, CS, & - sponge_CSp, diag_to_Z_CSp, tv) + sponge_CSp, tv) logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -165,8 +164,6 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_boundary_impulse_tracer. type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables ! Local variables diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 51b5ab6c08..39e250da65 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -4,7 +4,6 @@ module regional_dyes ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -99,7 +98,7 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & - "The number of dye tracers in this run. Each tracer \n"//& + "The number of dye tracers in this run. Each tracer "//& "should have a separate region.", default=0) allocate(CS%dye_source_minlon(CS%ntr), & CS%dye_source_maxlon(CS%ntr), & @@ -140,7 +139,7 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) CS%dye_source_mindepth(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MINDEPTH", CS%dye_source_mindepth, & - "This is the minumum depth at which we inject dyes.", & + "This is the minimum depth at which we inject dyes.", & units="m", scale=US%m_to_Z, fail_if_missing=.true.) if (minval(CS%dye_source_mindepth(:)) < -1.e29*US%m_to_Z) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MINDEPTH") @@ -184,8 +183,7 @@ end function register_dye_tracer !> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. -subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_CSp, & - diag_to_Z_CSp) +subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already been !! read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -200,8 +198,6 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C !! call to register_dye_tracer. type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure !! for the sponges, if they are in use. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. ! Local variables character(len=24) :: name ! A variable's name in a NetCDF file. diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 7abbafa5fc..4ea3611a2a 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -4,7 +4,6 @@ module dyed_obc_tracer ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -83,14 +82,14 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & - "The number of dye tracers in this run. Each tracer \n"//& + "The number of dye tracers in this run. Each tracer "//& "should have a separate boundary segment.", default=0) allocate(CS%ind_tr(CS%ntr)) allocate(CS%tr_desc(CS%ntr)) call get_param(param_file, mdl, "dyed_obc_TRACER_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the dyed_obc tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the dyed_obc tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -132,7 +131,7 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) end function register_dyed_obc_tracer !> Initializes the CS%ntr tracer fields in tr(:,:,:,:) and sets up the tracer output. -subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, diag_to_Z_CSp) +subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure logical, intent(in) :: restart !< .true. if the fields have already @@ -143,8 +142,6 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, dia type(ocean_OBC_type), pointer :: OBC !< Structure specifying open boundary options. type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to dyed_obc_register_tracer. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. ! Local variables real, allocatable :: temp(:,:,:) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 562947a011..d59fddbcba 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -4,7 +4,6 @@ module ideal_age_example ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -102,23 +101,23 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DO_IDEAL_AGE", do_ideal_age, & - "If true, use an ideal age tracer that is set to 0 age \n"//& + "If true, use an ideal age tracer that is set to 0 age "//& "in the mixed layer and ages at unit rate in the interior.", & default=.true.) call get_param(param_file, mdl, "DO_IDEAL_VINTAGE", do_vintage, & - "If true, use an ideal vintage tracer that is set to an \n"//& - "exponentially increasing value in the mixed layer and \n"//& + "If true, use an ideal vintage tracer that is set to an "//& + "exponentially increasing value in the mixed layer and "//& "is conserved thereafter.", default=.false.) call get_param(param_file, mdl, "DO_IDEAL_AGE_DATED", do_ideal_age_dated, & - "If true, use an ideal age tracer that is everywhere 0 \n"//& - "before IDEAL_AGE_DATED_START_YEAR, but the behaves like \n"//& - "the standard ideal age tracer - i.e. is set to 0 age in \n"//& + "If true, use an ideal age tracer that is everywhere 0 "//& + "before IDEAL_AGE_DATED_START_YEAR, but the behaves like "//& + "the standard ideal age tracer - i.e. is set to 0 age in "//& "the mixed layer and ages at unit rate in the interior.", & default=.false.) call get_param(param_file, mdl, "AGE_IC_FILE", CS%IC_file, & - "The file in which the age-tracer initial values can be \n"//& + "The file in which the age-tracer initial values can be "//& "found, or an empty string for internal initialization.", & default=" ") if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then @@ -131,9 +130,9 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "If true, AGE_IC_FILE is in depth space, not layer space", & default=.false.) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code \n"//& - "if they are not found in the restart files. Otherwise \n"//& - "it is a fatal error if the tracers are not found in the \n"//& + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& "restart files of a restarted run.", default=.false.) CS%ntr = 0 @@ -194,7 +193,7 @@ end function register_ideal_age_tracer !> Sets the ideal age traces to their initial values and sets up the tracer output subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -211,8 +210,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. + ! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 6156c20e24..7730b8f12e 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -4,7 +4,6 @@ module oil_tracer ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -110,7 +109,7 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "OIL_IC_FILE", CS%IC_file, & - "The file in which the oil tracer initial values can be \n"//& + "The file in which the oil tracer initial values can be "//& "found, or an empty string for internal initialization.", & default=" ") if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then @@ -124,9 +123,9 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) default=.false.) call get_param(param_file, mdl, "OIL_MAY_REINIT", CS%oil_may_reinit, & - "If true, oil tracers may go through the initialization \n"//& - "code if they are not found in the restart files. \n"//& - "Otherwise it is a fatal error if the oil tracers are not \n"//& + "If true, oil tracers may go through the initialization "//& + "code if they are not found in the restart files. "//& + "Otherwise it is a fatal error if the oil tracers are not "//& "found in the restart files of a restarted run.", & default=.false.) call get_param(param_file, mdl, "OIL_SOURCE_LONGITUDE", CS%oil_source_longitude, & @@ -136,14 +135,14 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "The geographic latitude of the oil source.", units="degrees N", & fail_if_missing=.true.) call get_param(param_file, mdl, "OIL_SOURCE_LAYER", CS%oil_source_k, & - "The layer into which the oil is introduced, or a \n"//& - "negative number for a vertically uniform source, \n"//& + "The layer into which the oil is introduced, or a "//& + "negative number for a vertically uniform source, "//& "or 0 not to use this tracer.", units="Layer", default=0) call get_param(param_file, mdl, "OIL_SOURCE_RATE", CS%oil_source_rate, & "The rate of oil injection.", units="kg s-1", default=1.0) call get_param(param_file, mdl, "OIL_DECAY_DAYS", CS%oil_decay_days, & - "The decay timescale in days (if positive), or no decay \n"//& - "if 0, or use the temperature dependent decay rate of \n"//& + "The decay timescale in days (if positive), or no decay "//& + "if 0, or use the temperature dependent decay rate of "//& "Adcroft et al. (GRL, 2010) if negative.", units="days", & default=0.0) call get_param(param_file, mdl, "OIL_DATED_START_YEAR", CS%oil_start_year, & @@ -202,7 +201,7 @@ end function register_oil_tracer !> Initialize the oil tracers and set up tracer output subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -219,8 +218,6 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_oil_tracer. type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. ! Local variables character(len=16) :: name ! A variable's name in a NetCDF file. diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index e41ab90095..ea3ccb8928 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -6,7 +6,6 @@ module pseudo_salt_tracer use MOM_debugging, only : hchksum use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -114,7 +113,7 @@ end function register_pseudo_salt_tracer !> Initialize the pseudo-salt tracer subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, & - sponge_CSp, diag_to_Z_CSp, tv) + sponge_CSp, tv) logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -130,8 +129,6 @@ subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_pseudo_salt_tracer. type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables ! This subroutine initializes the tracer fields in CS%ps(:,:,:). diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 26ea3fb957..9b36254206 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -4,7 +4,6 @@ module USER_tracer_example ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -87,8 +86,8 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "TRACER_EXAMPLE_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial \n"//& - "conditions for the DOME tracers, or blank to initialize \n"//& + "The name of a file from which to read the initial "//& + "conditions for the DOME tracers, or blank to initialize "//& "them internally.", default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") @@ -97,8 +96,8 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS CS%tracer_IC_file) endif call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & - "If true, sponges may be applied anywhere in the domain. \n"//& - "The exact location and properties of those sponges are \n"//& + "If true, sponges may be applied anywhere in the domain. "//& + "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 @@ -137,7 +136,7 @@ end function USER_register_tracer_example !> This subroutine initializes the NTR tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & - sponge_CSp, diag_to_Z_CSp) + sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -154,8 +153,6 @@ subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & !! call to USER_register_tracer_example. type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure !! for the sponges, if they are in use. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure - !! for diagnostics in depth space. ! Local variables real, allocatable :: temp(:,:,:) diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 3d54df5955..65cf4bc90a 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -192,16 +192,16 @@ subroutine BFB_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "LFR_SLAT", CS%lfrslat, & @@ -224,13 +224,13 @@ subroutine BFB_surface_forcing_init(Time, G, param_file, diag, CS) default=0.02) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index b81061ab29..a9a5be3d42 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -385,19 +385,19 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed call get_param(param_file, mdl, "DOME2D_WEST_SPONGE_TIME_SCALE", dome2d_west_sponge_time_scale, & - 'The time-scale on the west edge of the domain for restoring T/S\n' //& + 'The time-scale on the west edge of the domain for restoring T/S '//& 'in the sponge. If zero, the western sponge is disabled', & units='s', default=0.) call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_TIME_SCALE", dome2d_east_sponge_time_scale, & - 'The time-scale on the east edge of the domain for restoring T/S\n' //& + 'The time-scale on the east edge of the domain for restoring T/S '//& 'in the sponge. If zero, the eastern sponge is disabled', & units='s', default=0.) call get_param(param_file, mdl, "DOME2D_WEST_SPONGE_WIDTH", dome2d_west_sponge_width, & - 'The fraction of the domain in which the western sponge for restoring T/S\n' //& + 'The fraction of the domain in which the western sponge for restoring T/S '//& 'is active.', & units='nondim', default=0.1) call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_WIDTH", dome2d_east_sponge_width, & - 'The fraction of the domain in which the eastern sponge for restoring T/S\n' //& + 'The fraction of the domain in which the eastern sponge for restoring T/S '//& 'is active.', & units='nondim', default=0.1) diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 39c9321111..cce8b43a71 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -321,7 +321,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, case ( REGRIDDING_LAYER ) call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & - "If true, accept the prescribed temperature and fit the \n"//& + "If true, accept the prescribed temperature and fit the "//& "salinity; otherwise take salinity and fit temperature.", & default=.false., do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DS", drho_dS1, & @@ -628,16 +628,16 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! sponge, FIT_SALINITY=False. The oposite is true for temp. One can ! combined the *correct* temp and salt values in one file instead. call get_param(PF, mdl, "ISOMIP_SPONGE_FILE", state_file, & - "The name of the file with temps., salts. and interfaces to \n"// & + "The name of the file with temps., salts. and interfaces to "//& "damp toward.", fail_if_missing=.true.) call get_param(PF, mdl, "SPONGE_PTEMP_VAR", temp_var, & - "The name of the potential temperature variable in \n"//& + "The name of the potential temperature variable in "//& "SPONGE_STATE_FILE.", default="Temp") call get_param(PF, mdl, "SPONGE_SALT_VAR", salt_var, & - "The name of the salinity variable in \n"//& + "The name of the salinity variable in "//& "SPONGE_STATE_FILE.", default="Salt") call get_param(PF, mdl, "SPONGE_ETA_VAR", eta_var, & - "The name of the interface height variable in \n"//& + "The name of the interface height variable in "//& "SPONGE_STATE_FILE.", default="eta") !read temp and eta diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index efd75810d6..73d4a2ea1f 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -34,7 +34,7 @@ module Idealized_hurricane #include -public idealized_hurricane_wind_init !Public interface to intialize the idealized +public idealized_hurricane_wind_init !Public interface to initialize the idealized ! hurricane wind profile. public idealized_hurricane_wind_forcing !Public interface to update the idealized ! hurricane wind profile. @@ -121,25 +121,25 @@ subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) ! Parameters for computing a wind profile call get_param(param_file, mdl, "IDL_HURR_RHO_AIR", CS%rho_a, & - "Air density used to compute the idealized hurricane"// & + "Air density used to compute the idealized hurricane "//& "wind profile.", units='kg/m3', default=1.2) call get_param(param_file, mdl, "IDL_HURR_AMBIENT_PRESSURE", & - CS%pressure_ambient, "Ambient pressure used in the "// & + CS%pressure_ambient, "Ambient pressure used in the "//& "idealized hurricane wind profile.", units='Pa', & default=101200.) call get_param(param_file, mdl, "IDL_HURR_CENTRAL_PRESSURE", & - CS%pressure_central, "Central pressure used in the "// & + CS%pressure_central, "Central pressure used in the "//& "idealized hurricane wind profile.", units='Pa', & default=96800.) call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & - CS%rad_max_wind, "Radius of maximum winds used in the"// & + CS%rad_max_wind, "Radius of maximum winds used in the "//& "idealized hurricane wind profile.", units='m', & default=50.e3) call get_param(param_file, mdl, "IDL_HURR_MAX_WIND", CS%max_windspeed, & "Maximum wind speed used in the idealized hurricane"// & "wind profile.", units='m/s', default=65.) call get_param(param_file, mdl, "IDL_HURR_TRAN_SPEED", CS%hurr_translation_spd, & - "Translation speed of hurricane used in the idealized"// & + "Translation speed of hurricane used in the idealized "//& "hurricane wind profile.", units='m/s', default=5.0) call get_param(param_file, mdl, "IDL_HURR_TRAN_DIR", CS%hurr_translation_dir, & "Translation direction (towards) of hurricane used in the "//& @@ -153,7 +153,7 @@ subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) "Idealized Hurricane initial Y position", & units='m', default=0.) call get_param(param_file, mdl, "IDL_HURR_TAU_CURR_REL", CS%relative_tau, & - "Current relative stress switch"// & + "Current relative stress switch "//& "used in the idealized hurricane wind profile.", & units='', default=.false.) @@ -163,20 +163,20 @@ subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) "invoking a modification (bug) in the wind profile meant to "//& "reproduce a previous implementation.", units='', default=.false.) call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_MODE, & - "Single Column mode switch"// & + "Single Column mode switch "//& "used in the SCM idealized hurricane wind profile.", & units='', default=.false.) call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%DY_from_center, & - "Y distance of station used in the SCM idealized hurricane "// & + "Y distance of station used in the SCM idealized hurricane "//& "wind profile.", units='m', default=50.e3) ! The following parameters are model run-time parameters which are used ! and logged elsewhere and so should not be logged here. The default ! value should be consistent with the rest of the model. call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, do_not_log=.true.) call get_param(param_file, mdl, "GUST_CONST", CS%gustiness, & diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 6114464bf5..7df6390c10 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -75,11 +75,11 @@ function register_Kelvin_OBC(param_file, CS, OBC_Reg) call get_param(param_file, mdl, "TOPO_CONFIG", config, do_not_log=.true.) if (trim(config) == "Kelvin") then call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", CS%coast_offset1, & - "The distance along the southern and northern boundaries \n"//& + "The distance along the southern and northern boundaries "//& "at which the coasts angle in.", & units="km", default=100.0) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", CS%coast_offset2, & - "The distance from the southern and northern boundaries \n"//& + "The distance from the southern and northern boundaries "//& "at which the coasts angle in.", & units="km", default=10.0) call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", CS%coast_angle, & diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index a061fcb3eb..3ba4f0c376 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -509,11 +509,11 @@ subroutine controlled_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call log_param(param_file, mdl, "CTRL_FORCE_INTEGRATED", do_integrated, & - "If true, use a PI controller to determine the surface \n"//& + "If true, use a PI controller to determine the surface "//& "forcing that is consistent with the observed mean properties.", & default=.false.) call log_param(param_file, mdl, "CTRL_FORCE_NUM_CYCLE", num_cycle, & - "The number of cycles per year in the controlled forcing, \n"//& + "The number of cycles per year in the controlled forcing, "//& "or 0 for no cyclic forcing.", default=0) if (.not.associated(CS)) return @@ -521,33 +521,33 @@ subroutine controlled_forcing_init(Time, G, param_file, diag, CS) CS%diag => diag call get_param(param_file, mdl, "CTRL_FORCE_HEAT_INT_RATE", CS%heat_int_rate, & - "The integrated rate at which heat flux anomalies are \n"//& + "The integrated rate at which heat flux anomalies are "//& "accumulated.", units="s-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_PREC_INT_RATE", CS%prec_int_rate, & - "The integrated rate at which precipitation anomalies \n"//& + "The integrated rate at which precipitation anomalies "//& "are accumulated.", units="s-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_HEAT_CYC_RATE", CS%heat_cyc_rate, & - "The integrated rate at which cyclical heat flux \n"//& + "The integrated rate at which cyclical heat flux "//& "anomalies are accumulated.", units="s-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_PREC_CYC_RATE", CS%prec_cyc_rate, & - "The integrated rate at which cyclical precipitation \n"//& + "The integrated rate at which cyclical precipitation "//& "anomalies are accumulated.", units="s-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_SMOOTH_LENGTH", smooth_len, & - "The length scales over which controlled forcing \n"//& + "The length scales over which controlled forcing "//& "anomalies are smoothed.", units="m", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_HEAT", CS%lam_heat, & - "A constant of proportionality between SST anomalies \n"//& + "A constant of proportionality between SST anomalies "//& "and controlling heat fluxes", "W m-2 K-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_PREC", CS%lam_prec, & - "A constant of proportionality between SSS anomalies \n"//& + "A constant of proportionality between SSS anomalies "//& "(normalised by mean SSS) and controlling precipitation.", & "kg m-2", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_CYC_HEAT", CS%lam_cyc_heat, & - "A constant of proportionality between SST anomalies \n"//& + "A constant of proportionality between SST anomalies "//& "and cyclical controlling heat fluxes", "W m-2 K-1", default=0.0) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_CYC_PREC", CS%lam_cyc_prec, & - "A constant of proportionality between SSS anomalies \n"//& - "(normalised by mean SSS) and cyclical controlling \n"//& + "A constant of proportionality between SSS anomalies "//& + "(normalised by mean SSS) and cyclical controlling "//& "precipitation.", "kg m-2", default=0.0) CS%Len2 = smooth_len**2 diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index c3a262ad92..ecf373681d 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -181,6 +181,7 @@ module MOM_wave_interface ! Options For Test Prof Real :: TP_STKX0, TP_STKY0, TP_WVL logical :: WaveAgePeakFreq ! Flag to use W +logical :: StaticWaves, DHH85_Is_Set real :: WaveAge, WaveWind real :: PI !!@} @@ -269,7 +270,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) units='', default=NULL_STRING) select case (TRIM(TMPSTRING1)) case (NULL_STRING)! No Waves - call MOM_error(FATAL, "wave_interface_init called with no specified"//& + call MOM_error(FATAL, "wave_interface_init called with no specified "//& "WAVE_METHOD.") case (TESTPROF_STRING)! Test Profile WaveMethod = TESTPROF @@ -302,9 +303,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) case (INPUT_STRING)! A method to input the Stokes band (globally uniform) DataSource = Input call get_param(param_file,mdl,"SURFBAND_NB",NumBands, & - "Prescribe number of wavenumber bands for Stokes drift. \n"// & - " Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and \n"// & - " STOKES_Y, there are no safety checks in the code.", & + "Prescribe number of wavenumber bands for Stokes drift. "// & + "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "// & + "STOKES_Y, there are no safety checks in the code.", & units='', default=1) allocate( CS%WaveNum_Cen(1:NumBands) ) CS%WaveNum_Cen(:) = 0.0 @@ -343,6 +344,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call get_param(param_file,mdl,"DHH85_WIND",WaveWind, & "Wind speed for DHH85 spectrum.", & units='', default=10.0) + call get_param(param_file,mdl,"STATIC_DHH85",StaticWaves, & + "Flag to disable updating DHH85 Stokes drift.", & + default=.false.) case (LF17_STRING)!Li and Fox-Kemper 17 wind-sea Langmuir number WaveMethod = LF17 case default @@ -351,16 +355,16 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in \n"//& - " Lanmguir number calculation, where La = sqrt(ust/Stokes).", & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & units="nondim",default=0.04) call get_param(param_file, mdl, "LA_MISALIGNMENT", LA_Misalignment, & "Flag (logical) if using misalignment bt shear and waves in LA",& default=.false.) call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & - "A minimum value for all Langmuir numbers that is not physical, \n"//& - " but is likely only encountered when the wind is very small and \n"//& - " therefore its effects should be mostly benign.",units="nondim",& + "A minimum value for all Langmuir numbers that is not physical, "//& + "but is likely only encountered when the wind is very small and "//& + "therefore its effects should be mostly benign.",units="nondim",& default=0.05) ! Allocate and initialize @@ -404,18 +408,26 @@ end subroutine MOM_wave_interface_init !! with the wind-speed dependent Stokes drift formulation of LF17 subroutine MOM_wave_interface_init_lite(param_file) type(param_file_type), intent(in) :: param_file !< Input parameter structure + character*(5), parameter :: NULL_STRING = "EMPTY" + character*(4), parameter :: LF17_STRING = "LF17" + character*(13) :: TMPSTRING1 + logical :: StatisticalWaves ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in \n"//& - " Lanmguir number calculation, where La = sqrt(ust/Stokes).", & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & units="nondim",default=0.04) - if (WaveMethod==NULL_WaveMethod) then - ! Wave not initialized. Check for WaveMethod. Only allow LF17. - WaveMethod=LF17 + ! Check if using LA_LI2016 + call get_param(param_file,mdl,"USE_LA_LI2016",StatisticalWaves, & + do_not_log=.true.,default=.false.) + if (StatisticalWaves) then + WaveMethod = LF17 PI=4.0*atan(1.0) - endif + else + WaveMethod = NULL_WaveMethod + end if return end subroutine MOM_wave_interface_init_lite @@ -608,45 +620,48 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo enddo elseif (WaveMethod==DHH85) then - do II = G%isdB,G%iedB - do jj = G%jsd,G%jed - bottom = 0.0 - do kk = 1,G%ke - Top = Bottom - IIm1 = max(II-1,1) - MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) - !bgr note that this is using a u-point ii on h-point ustar - ! this code has only been previous used for uniform - ! grid cases. This needs fixed if DHH85 is used for non - ! uniform cases. - call DHH85_mid(GV, US, MidPoint, UStokes) - ! Putting into x-direction (no option for direction - CS%US_x(II,jj,kk) = UStokes + if (.not.(StaticWaves .and. DHH85_is_set)) then + do II = G%isdB,G%iedB + do jj = G%jsd,G%jed + bottom = 0.0 + do kk = 1,G%ke + Top = Bottom + IIm1 = max(II-1,1) + MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) + Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) + !bgr note that this is using a u-point ii on h-point ustar + ! this code has only been previous used for uniform + ! grid cases. This needs fixed if DHH85 is used for non + ! uniform cases. + call DHH85_mid(GV, US, MidPoint, UStokes) + ! Putting into x-direction (no option for direction + CS%US_x(II,jj,kk) = UStokes + enddo enddo enddo - enddo - do ii = G%isd,G%ied - do JJ = G%jsdB,G%jedB - Bottom = 0.0 - do kk=1, G%ke - Top = Bottom - JJm1 = max(JJ-1,1) - MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - !bgr note that this is using a v-point jj on h-point ustar - ! this code has only been previous used for uniform - ! grid cases. This needs fixed if DHH85 is used for non - ! uniform cases. - ! call DHH85_mid(GV, US, Midpoint, UStokes) - ! Putting into x-direction, so setting y direction to 0 - CS%US_y(ii,JJ,kk) = 0.0 !### Note that =0 should be =US - RWH - ! bgr - see note above, but this is true - ! if this is used for anything - ! other than simple LES comparison + do ii = G%isd,G%ied + do JJ = G%jsdB,G%jedB + Bottom = 0.0 + do kk=1, G%ke + Top = Bottom + JJm1 = max(JJ-1,1) + MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + !bgr note that this is using a v-point jj on h-point ustar + ! this code has only been previous used for uniform + ! grid cases. This needs fixed if DHH85 is used for non + ! uniform cases. + ! call DHH85_mid(GV, US, Midpoint, UStokes) + ! Putting into x-direction, so setting y direction to 0 + CS%US_y(ii,JJ,kk) = 0.0 !### Note that =0 should be =US - RWH + ! bgr - see note above, but this is true + ! if this is used for anything + ! other than simple LES comparison + enddo enddo enddo - enddo + DHH85_is_set = .true. + endif else! Keep this else, fallback to 0 Stokes drift do kk= 1,G%ke do II = G%isdB,G%iedB @@ -669,7 +684,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do jj = G%jsc, G%jec Top = h(ii,jj,1)*GV%H_to_Z call get_Langmuir_Number( La, G, GV, US, Top, US%Z_to_m*ustar(ii,jj), ii, jj, & - Override_MA=.false.,WAVES=CS) + H(ii,jj,:),Override_MA=.false.,WAVES=CS) CS%La_turb(ii,jj) = La enddo enddo @@ -943,6 +958,11 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) elseif (WaveMethod==LF17) then call get_StokesSL_LiFoxKemper(ustar, hbl*LA_FracHBL, GV, US, LA_STK, LA) + elseif (WaveMethod==Null_WaveMethod) then + call MOM_error(FATAL, "Get_Langmuir_number called without defining a WaveMethod. "//& + "Suggest to make sure USE_LT is set/overridden to False or "//& + "choose a wave method (or set USE_LA_LI2016 to use statistical "//& + "waves.") endif if (.not.(WaveMethod==LF17)) then @@ -1146,9 +1166,10 @@ subroutine DHH85_mid(GV, US, zpt, UStokes) !/ omega_min = 0.1 ! Hz ! Cut off at 30cm for now... - omega_max = 6.5 ! ~sqrt(0.2*(GV%g_Earth*US%m_to_Z)*2*pi/0.3) - domega = 0.05 - NOmega = (omega_max-omega_min)/domega + omega_max = 10. ! ~sqrt(0.2*(GV%g_Earth*US%m_to_Z)*2*pi/0.3) + NOmega = 1000 + domega = (omega_max-omega_min)/real(NOmega) + ! if (WaveAgePeakFreq) then omega_peak = (GV%g_Earth*US%m_to_Z) / (WA * u10) diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index adfff7949f..ab964b5269 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -67,14 +67,13 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par if (.not.just_read) call log_version(param_file, mdl, version) call get_param(param_file, mdl, "HALF_STRAT_DEPTH", half_strat, & -!### UNCOMMENT TO FIX THIS "The fractional depth where the stratification is centered.", & - "The maximum depth of the ocean.", & + "The fractional depth where the stratification is centered.", & units="nondim", default = 0.5, do_not_log=just_read) call get_param(param_file, mdl, "JET_WIDTH", jet_width, & "The width of the zonal-mean jet.", units="km", & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & - "The interface height scale associated with the \n"//& + "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.not.just_read, do_not_log=just_read) @@ -148,7 +147,7 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p "The width of the zonal-mean jet.", units="km", & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & - "The interface height scale associated with the \n"//& + "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.not.just_read, do_not_log=just_read) @@ -249,7 +248,7 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) "The width of the zonal-mean jet.", units="km", & fail_if_missing=.true.) call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & - "The interface height scale associated with the \n"//& + "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.true.) diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 new file mode 100644 index 0000000000..f0000dc03d --- /dev/null +++ b/src/user/RGC_initialization.F90 @@ -0,0 +1,238 @@ +module RGC_initialization +!*********************************************************************** +!* GNU General Public License * +!* This file is a part of MOM. * +!* * +!* MOM is free software; you can redistribute it and/or modify it and * +!* are expected to follow the terms of the GNU General Public License * +!* as published by the Free Software Foundation; either version 2 of * +!* the License, or (at your option) any later version. * +!* * +!* MOM is distributed in the hope that it will be useful, but WITHOUT * +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * +!* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * +!* License for more details. * +!* * +!* For the full text of the GNU General Public License, * +!* write to: Free Software Foundation, Inc., * +!* 675 Mass Ave, Cambridge, MA 02139, USA. * +!* or see: http://www.gnu.org/licenses/gpl.html * +!* By Elizabeth Yankovsky, May 2018 * +!*********************************************************************** + +use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge +use MOM_ALE_sponge, only : set_up_ALE_sponge_vel_field +use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_sponge, only : set_up_sponge_ML_density +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, read_data +use MOM_io, only : slasher +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type +use MOM_domains, only: pass_var +implicit none ; private + +#include + +character(len=40) :: mod = "RGC_initialization" ! This module's name. +public RGC_initialize_sponges + +contains + +!> Sets up the the inverse restoration time (Idamp), and +! the values towards which the interface heights and an arbitrary +! number of tracers should be restored within each sponge. +subroutine RGC_initialize_sponges(G, GV, tv, u, v, PF, use_ALE, CSp, ACSp) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL ptrs. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< u velocity. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< v velocity. + type(param_file_type), intent(in) :: PF !< A structure indicating the + !! open file to parse for model + !! parameter values. + logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode + type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure + type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure + +! Local variables + real :: T(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for temp + real :: S(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for salt + real :: U1(SZIB_(G), SZJ_(G), SZK_(G)) ! A temporary array for u + real :: V1(SZI_(G), SZJB_(G), SZK_(G)) ! A temporary array for v + real :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO + real :: tmp(SZI_(G),SZJ_(G)) ! A temporary array for tracers. + real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness at h points + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate at h points, in s-1. + real :: TNUDG ! Nudging time scale, days + real :: pres(SZI_(G)) ! An array of the reference pressure, in Pa + real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! + ! negative because it is positive upward. ! + real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta. + ! positive upward, in m. + logical :: sponge_uv ! Nudge velocities (u and v) towards zero + real :: min_depth, dummy1, z, delta_h + real :: damp, rho_dummy, min_thickness, rho_tmp, xi0 + real :: lenlat, lenlon, lensponge + character(len=40) :: filename, state_file + character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var + + character(len=40) :: mod = "RGC_initialize_sponges" ! This subroutine's name. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, iscB, iecB, jscB, jecB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB + + call get_param(PF,mod,"MIN_THICKNESS",min_thickness,'Minimum layer thickness',units='m',default=1.e-3) + + call get_param(PF, mod, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers (days)', default=0.0) + + call get_param(PF, mod, "LENLAT", lenlat, & + "The latitudinal or y-direction length of the domain", & + fail_if_missing=.true., do_not_log=.true.) + + call get_param(PF, mod, "LENLON", lenlon, & + "The longitudinal or x-direction length of the domain", & + fail_if_missing=.true., do_not_log=.true.) + + call get_param(PF, mod, "LENSPONGE", lensponge, & + "The length of the sponge layer (km).", & + default=10.0) + + call get_param(PF, mod, "SPONGE_UV", sponge_uv, & + "Nudge velocities (u and v) towards zero in the sponge layer.", & + default=.false., do_not_log=.true.) + + T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0; RHO(:,:,:) = 0.0 + + call get_param(PF, mod, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0) + + if (associated(CSp)) call MOM_error(FATAL, & + "RGC_initialize_sponges called with an associated control structure.") + if (associated(ACSp)) call MOM_error(FATAL, & + "RGC_initialize_sponges called with an associated ALE-sponge control structure.") + + ! Here the inverse damping time, in s-1, is set. Set Idamp to 0 ! + ! wherever there is no sponge, and the subroutines that are called ! + ! will automatically set up the sponges only where Idamp is positive! + ! and mask2dT is 1. + + do i=is,ie; do j=js,je + if (G%geoLonT(i,j) <= lensponge) then + dummy1 = -(G%geoLonT(i,j))/lensponge + 1.0 + !damp = 1.0/TNUDG * max(0.0,dummy1) + damp = 0.0 + !write(*,*)'1st, G%geoLonT(i,j), damp',G%geoLonT(i,j), damp + + elseif (G%geoLonT(i,j) >= (lenlon - lensponge) .AND. G%geoLonT(i,j) <= lenlon) then + + ! 1 / day + dummy1=(G%geoLonT(i,j)-(lenlon - lensponge))/(lensponge) + damp = (1.0/TNUDG) * max(0.0,dummy1) + + else ; damp=0.0 + endif + + ! convert to 1 / seconds + if (G%bathyT(i,j) > min_depth) then + Idamp(i,j) = damp/86400.0 + else ; Idamp(i,j) = 0.0 ; endif + enddo ; enddo + + + ! 1) Read eta, salt and temp from IC file + call get_param(PF, mod, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + ! GM: get two different files, one with temp and one with salt values + ! this is work around to avoid having wrong values near the surface + ! because of the FIT_SALINITY option. To get salt values right in the + ! sponge, FIT_SALINITY=False. The oposite is true for temp. One can + ! combined the *correct* temp and salt values in one file instead. + call get_param(PF, mod, "RGC_SPONGE_FILE", state_file, & + "The name of the file with temps., salts. and interfaces to \n"// & + " damp toward.", fail_if_missing=.true.) + call get_param(PF, mod, "SPONGE_PTEMP_VAR", temp_var, & + "The name of the potential temperature variable in \n"//& + "SPONGE_STATE_FILE.", default="Temp") + call get_param(PF, mod, "SPONGE_SALT_VAR", salt_var, & + "The name of the salinity variable in \n"//& + "SPONGE_STATE_FILE.", default="Salt") + call get_param(PF, mod, "SPONGE_ETA_VAR", eta_var, & + "The name of the interface height variable in \n"//& + "SPONGE_STATE_FILE.", default="eta") + call get_param(PF, mod, "SPONGE_H_VAR", h_var, & + "The name of the layer thickness variable in \n"//& + "SPONGE_STATE_FILE.", default="h") + + !read temp and eta + filename = trim(inputdir)//trim(state_file) + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " RGC_initialize_sponges: Unable to open "//trim(filename)) + call read_data(filename,temp_var,T(:,:,:), domain=G%Domain%mpp_domain) + call read_data(filename,salt_var,S(:,:,:), domain=G%Domain%mpp_domain) + + if (use_ALE) then + + call read_data(filename,h_var,h(:,:,:), domain=G%Domain%mpp_domain) + call pass_var(h, G%domain) + + !call initialize_ALE_sponge(Idamp, h, nz, G, PF, ACSp) + call initialize_ALE_sponge(Idamp, G, PF, ACSp, h, nz) + + ! The remaining calls to set_up_sponge_field can be in any order. ! + if ( associated(tv%T) ) then + call set_up_ALE_sponge_field(T,G,tv%T,ACSp) + endif + if ( associated(tv%S) ) then + call set_up_ALE_sponge_field(S,G,tv%S,ACSp) + endif + + if (sponge_uv) then + U1(:,:,:) = 0.0; V1(:,:,:) = 0.0 + call set_up_ALE_sponge_vel_field(U1,V1,G,u,v,ACSp) + endif + + + else ! layer mode + + !read eta + call read_data(filename,eta_var,eta(:,:,:), domain=G%Domain%mpp_domain) + + ! Set the inverse damping rates so that the model will know where to + ! apply the sponges, along with the interface heights. + call initialize_sponge(Idamp, eta, G, PF, CSp, GV) + + if ( GV%nkml>0 ) then + ! This call to set_up_sponge_ML_density registers the target values of the + ! mixed layer density, which is used in determining which layers can be + ! inflated without causing static instabilities. + do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + + do j=js,je + call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), & + is, ie-is+1, tv%eqn_of_state) + enddo + + call set_up_sponge_ML_density(tmp, G, CSp) + endif + + ! Apply sponge in tracer fields + call set_up_sponge_field(T, tv%T, G, nz, CSp) + call set_up_sponge_field(S, tv%S, G, nz, CSp) + + endif + +end subroutine RGC_initialize_sponges + +end module RGC_initialization diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 4372586820..eb7f765890 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -60,15 +60,15 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_para if (.not.just_read) call log_version(param_file, mdl, version, "") ! Parameters read by cartesian grid initialization call get_param(param_file, mdl, "DISK_RADIUS", diskrad, & - "The radius of the initially elevated disk in the \n"//& + "The radius of the initially elevated disk in the "//& "circle_obcs test case.", units=G%x_axis_units, & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "DISK_X_OFFSET", xOffset, & - "The x-offset of the initially elevated disk in the \n"//& + "The x-offset of the initially elevated disk in the "//& "circle_obcs test case.", units=G%x_axis_units, & default = 0.0, do_not_log=just_read) call get_param(param_file, mdl, "DISK_IC_AMPLITUDE", IC_amp, & - "Initial amplitude of interface height displacements \n"//& + "Initial amplitude of interface height displacements "//& "in the circle_obcs test case.", & units='m', default=5.0, scale=GV%m_to_H, do_not_log=just_read) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index c6e6354ef3..b16b3a341c 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -132,7 +132,7 @@ subroutine dumbbell_initialize_thickness ( h, G, GV, US, param_file, just_read_p call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & - "The granularity of initial interface height values \n"//& + "The granularity of initial interface height values "//& "per meter, to avoid sensivity to order-of-arithmetic changes.", & default=2048.0, units="m-1", scale=US%Z_to_m, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -220,7 +220,7 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_DENSITY_PROFILE", density_profile, & - 'Initial profile shape. Valid values are "linear", "parabolic"\n'// & + 'Initial profile shape. Valid values are "linear", "parabolic" '// & 'and "exponential".', default='linear', do_not_log=just_read) call get_param(param_file, mdl,"DUMBBELL_SREF", S_surf, & 'DUMBBELL REFERENCE SALINITY', units='1e-3', default=34., do_not_log=just_read) diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 7a2360fc7a..6d3e46bd73 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -203,16 +203,16 @@ subroutine dumbbell_surface_forcing_init(Time, G, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& + "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "DUMBBELL_SLP_AMP", CS%slp_amplitude, & @@ -231,13 +231,13 @@ subroutine dumbbell_surface_forcing_init(Time, G, param_file, diag, CS) default=2., do_not_log=.true.) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back \n"//& - "toward some specified surface state with a rate \n"//& + "If true, the buoyancy fluxes drive the model back "//& + "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& + "The constant that relates the restoring surface fluxes "//& + "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", units="m day-1", & fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index cb1b9a6b2f..61f8183275 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -101,7 +101,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) 'dyed_channel_set_OBC_data() was called but OBC type was not initialized!') call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & - "The number of dye tracers in this run. Each tracer \n"//& + "The number of dye tracers in this run. Each tracer "//& "should have a separate boundary segment.", default=0, & do_not_log=.true.) diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index eed0f804b4..39519ce8a6 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -52,7 +52,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) if (.not.associated(OBC)) return call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & - "The number of dye tracers in this run. Each tracer \n"//& + "The number of dye tracers in this run. Each tracer "//& "should have a separate boundary segment.", default=0, & do_not_log=.true.) diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index c442f63891..1a3e8dd308 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -56,12 +56,12 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "FRONT_DISPLACEMENT", front_displacement, & - "The vertical displacement of interfaces across the front. \n"//& + "The vertical displacement of interfaces across the front. "//& "A value larger in magnitude that MAX_DEPTH is truncated,", & units="m", fail_if_missing=.not.just_read, do_not_log=just_read, scale=US%m_to_Z) call get_param(param_file, mdl, "THERMOCLINE_THICKNESS", thermocline_thickness, & - "The thickness of the thermocline in the lock exchange \n"//& - "experiment. A value of zero creates a two layer system \n"//& + "The thickness of the thermocline in the lock exchange "//& + "experiment. A value of zero creates a two layer system "//& "with vanished layers in between the two inflated layers.", & default=0., units="m", do_not_log=just_read, scale=US%m_to_Z) diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 6180ff2e00..0df24efb42 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -53,11 +53,11 @@ subroutine seamount_initialize_topography( D, G, param_file, max_depth ) "Non-dimensional height of seamount.", & units="non-dim", default=0.5) call get_param(param_file, mdl,"SEAMOUNT_X_LENGTH_SCALE",Lx, & - "Length scale of seamount in x-direction.\n"//& + "Length scale of seamount in x-direction. "//& "Set to zero make topography uniform in the x-direction.", & units="Same as x,y", default=20.) call get_param(param_file, mdl,"SEAMOUNT_Y_LENGTH_SCALE",Ly, & - "Length scale of seamount in y-direction.\n"//& + "Length scale of seamount in y-direction. "//& "Set to zero make topography uniform in the y-direction.", & units="Same as x,y", default=0.) @@ -132,7 +132,7 @@ subroutine seamount_initialize_thickness ( h, G, GV, US, param_file, just_read_p call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & - "The granularity of initial interface height values \n"//& + "The granularity of initial interface height values "//& "per meter, to avoid sensivity to order-of-arithmetic changes.", & default=2048.0, units="m-1", scale=US%Z_to_m, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -217,7 +217,7 @@ subroutine seamount_initialize_temperature_salinity ( T, S, h, G, GV, param_file call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_DENSITY_PROFILE", density_profile, & - 'Initial profile shape. Valid values are "linear", "parabolic"\n'// & + 'Initial profile shape. Valid values are "linear", "parabolic" '//& 'and "exponential".', default='linear', do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & 'Initial surface salinity', units='1e-3', default=34., do_not_log=just_read) diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 1a52519122..cd80514bea 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -69,7 +69,7 @@ function register_shelfwave_OBC(param_file, CS, OBC_Reg) "Length scale of shelfwave in x-direction.",& units="Same as x,y", default=100.) call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE",CS%Ly, & - "Length scale of exponential dropoff of topography\n"//& + "Length scale of exponential dropoff of topography "//& "in the y-direction.", & units="Same as x,y", default=50.) call get_param(param_file, mdl,"SHELFWAVE_Y_MODE",CS%jj, & diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 990d43fda4..e099d808d5 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -84,7 +84,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, US, param_file, just_read_p just_read = .false. ; if (present(just_read_params)) just_read = just_read_params if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SLOSHING_IC_AMPLITUDE", a0, & - "Initial amplitude of sloshing internal interface height \n"//& + "Initial amplitude of sloshing internal interface height "//& "displacements it the sloshing test case.", & units='m', default=75.0, scale=US%m_to_Z, do_not_log=just_read) call get_param(param_file, mdl, "SLOSHING_IC_BUG", use_IC_bug, & diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 5a29614506..10d04af0c3 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -26,7 +26,7 @@ module user_change_diffusivity !> Control structure for user_change_diffusivity type, public :: user_change_diff_CS ; private real :: Kd_add !< The scale of a diffusivity that is added everywhere - !! without any filtering or scaling [Z2 s-1 ~> m2 s-1]. + !! without any filtering or scaling [Z2 T-1 ~> m2 s-1]. real :: lat_range(4) !< 4 values that define the latitude range over which !! a diffusivity scaled by Kd_add is added [degLat]. real :: rho_range(4) !< 4 values that define the coordinate potential @@ -53,16 +53,16 @@ subroutine user_change_diff(h, tv, G, GV, CS, Kd_lay, Kd_int, T_f, S_f, Kd_int_a !! fields. Absent fields have NULL ptrs. type(user_change_diff_CS), pointer :: CS !< This module's control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of - !! each layer [Z2 s-1 ~> m2 s-1]. + !! each layer [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity - !! at each interface [Z2 s-1 ~> m2 s-1]. + !! at each interface [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: T_f !< Temperature with massless !! layers filled in vertically [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: S_f !< Salinity with massless !! layers filled in vertically [ppt]. real, dimension(:,:,:), optional, pointer :: Kd_int_add !< The diapycnal !! diffusivity that is being added at - !! each interface [Z2 s-1 ~> m2 s-1]. + !! each interface [Z2 T-1 ~> m2 s-1]. ! Local variables real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density in layers [kg m-3]. real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures. @@ -221,25 +221,26 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USER_KD_ADD", CS%Kd_add, & - "A user-specified additional diffusivity over a range of \n"//& - "latitude and density.", default=0.0, units="m2 s-1", scale=US%m_to_Z**2) + "A user-specified additional diffusivity over a range of "//& + "latitude and density.", default=0.0, units="m2 s-1", & + scale=US%m2_s_to_Z2_T) if (CS%Kd_add /= 0.0) then call get_param(param_file, mdl, "USER_KD_ADD_LAT_RANGE", CS%lat_range(:), & - "Four successive values that define a range of latitudes \n"//& - "over which the user-specified extra diffusivity is \n"//& - "applied. The four values specify the latitudes at \n"//& - "which the extra diffusivity starts to increase from 0, \n"//& - "hits its full value, starts to decrease again, and is \n"//& + "Four successive values that define a range of latitudes "//& + "over which the user-specified extra diffusivity is "//& + "applied. The four values specify the latitudes at "//& + "which the extra diffusivity starts to increase from 0, "//& + "hits its full value, starts to decrease again, and is "//& "back to 0.", units="degree", default=-1.0e9) call get_param(param_file, mdl, "USER_KD_ADD_RHO_RANGE", CS%rho_range(:), & - "Four successive values that define a range of potential \n"//& - "densities over which the user-given extra diffusivity \n"//& - "is applied. The four values specify the density at \n"//& - "which the extra diffusivity starts to increase from 0, \n"//& - "hits its full value, starts to decrease again, and is \n"//& + "Four successive values that define a range of potential "//& + "densities over which the user-given extra diffusivity "//& + "is applied. The four values specify the density at "//& + "which the extra diffusivity starts to increase from 0, "//& + "hits its full value, starts to decrease again, and is "//& "back to 0.", units="kg m-3", default=-1.0e9) call get_param(param_file, mdl, "USER_KD_ADD_USE_ABS_LAT", CS%use_abs_lat, & - "If true, use the absolute value of latitude when \n"//& + "If true, use the absolute value of latitude when "//& "checking whether a point fits into range of latitudes.", & default=.false.) endif